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.
---
 src/Cana.hs | 33 ++++++++++++++-------------------
 1 file changed, 14 insertions(+), 19 deletions(-)

(limited to 'src/Cana.hs')

diff --git a/src/Cana.hs b/src/Cana.hs
index bd425ef..ca87fa1 100644
--- a/src/Cana.hs
+++ b/src/Cana.hs
@@ -25,7 +25,7 @@
 -- > main :: IO ()
 -- > main = runGeminiServer Nothing defaultGeminiPort "certificate.crt" "private.key"
 -- >   [ (anyRoute, const $ return defaultResponse)
--- >   ]
+-- >   ] >> return ()
 --
 -- Note that the module is split in a few different submodules:
 --
@@ -35,12 +35,13 @@
 -- * "Cana.Protocol" contains low-level protocol definitions from the
 --   specification, such as a variety of status codes.
 -- * "Cana.Router" defines functions for defining 'Route's.
+-- * "Cana.Handlers" contains many pre-defined request handlers.
 
 module Cana
     ( -- * High-Level API
       runGeminiServer
+    , runGeminiServer'
       -- * Low-Level API
-    , loadCredentials
     , canaServer
     , canaClient
     , writeResponse
@@ -77,7 +78,7 @@ runGeminiServer :: Maybe HostName -- ^ Hostname to bind to.
                 -> FilePath       -- ^ Certificate key file.
                 -> FilePath       -- ^ Private key file.
                 -> [Route]        -- ^ Server routes.
-                -> IO ()
+                -> IO (Either String ())
 runGeminiServer hostName serviceName credFile keyFile routes = do
   creds <- loadCredentials credFile keyFile
   let vhost = VirtualHost {
@@ -85,24 +86,18 @@ runGeminiServer hostName serviceName credFile keyFile routes = do
     , vhostCredentials = creds
     , vhostRoutes      = routes
     }
-  result <- runCana (mkGeminiServer hostName serviceName creds [vhost]) canaServer
-  case result of
-    Right _ -> return ()
-    Left  s -> fail s
+  runGeminiServer' (mkGeminiServer hostName serviceName creds [vhost])
 
--- | Load the credentials.
+-- | Run the Gemini server.
 --
--- This uses 'fail' if the loading of the credentials fails.
-loadCredentials :: FilePath -- ^ Certificate file path.
-                -> FilePath -- ^ Private key file path.
-                -> IO TLS.Credentials -- ^ The loaded credentials.
-loadCredentials certFile keyFile = do
-  creds <- TLS.credentialLoadX509 "certificate.crt" "private.key" >>= unwrap
-  return $ TLS.Credentials [creds]
-    where
-      unwrap :: Either String a -> IO a
-      unwrap (Left s) = fail s
-      unwrap (Right x) = pure x
+-- This is a more advanced version of 'runGeminiServer' that takes in the
+-- 'GeminiServer' directly. This allows more fine grained control at the cost
+-- of more cumbersome setup (e.g. you have to load the credentials manually,
+-- ...).
+--
+-- This function returns inner errors, if any occur.
+runGeminiServer' :: GeminiServer -> IO (Either String ())
+runGeminiServer' = flip runCana canaServer
 
 -- | Run the actual Gemini server.
 --
-- 
cgit v1.2.3