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.

5 files changed, 171 insertions, 32 deletions

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.
 --
diff --git a/src/Cana/Extra.hs b/src/Cana/Handlers.hs
index b7119d6..512ebf3 100644
--- a/src/Cana/Extra.hs
+++ b/src/Cana/Handlers.hs
@@ -1,11 +1,11 @@
 {-# LANGUAGE OverloadedStrings, ScopedTypeVariables, PartialTypeSignatures #-}
 -- |
--- Module     : Cana.Extra
+-- Module     : Cana.Handlers
 --
--- This module contains some extra goodies for writing a Gemini server with
--- "Cana", for exmaple a static file server.
+-- This module contains pre-defined content handlers, like static file handlers
+-- or functions to run CGI scripts.
 
-module Cana.Extra
+module Cana.Handlers
     ( -- * High-Level handlers
       staticFiles
     , runCGI
diff --git a/src/Cana/Server.hs b/src/Cana/Server.hs
index 4171a25..9454365 100644
--- a/src/Cana/Server.hs
+++ b/src/Cana/Server.hs
@@ -1,19 +1,39 @@
+{-# LANGUAGE OverloadedStrings #-}
 -- |
 -- Module     : Cana.Server
 --
 -- This module contains types that are needed for the Cana Gemini server.
 
-module Cana.Server where
+module Cana.Server
+  ( -- * Configuration access
+    loadConfig
+  , parseConfig
+    -- * Programmatic configuration
+  , mkGeminiServer
+    -- * Helper functions
+  , loadCredentials
+  , hostMatches
+  , findVHost
+  ) where
 
-import Cana.Types
-import Cana.Util
+import           Cana.Protocol
+import           Cana.Types
+import           Cana.Util
+import           Cana.Handlers
 
-import Data.List
-import Data.Maybe
-import Data.Default
-import Network.Socket (HostName, ServiceName)
-import qualified Network.TLS as TLS
+import           Control.Monad.Trans.Except
+import           Control.Monad.IO.Class
+import           Data.List
+import           Data.Maybe
+import           Data.Default
+import qualified Data.ByteString          as BS
+import qualified Data.ByteString.UTF8     as UTF8
+import           Network.URI
+import           Network.Socket           (HostName, ServiceName)
+import qualified Network.TLS              as TLS
 import qualified Network.TLS.Extra.Cipher as TE
+import           Xeno.DOM
+import           Text.Regex.TDFA
 
 -- | Construct a Gemini server with the given credentials.
 --
@@ -48,6 +68,95 @@ mkGeminiServer hostName port creds vhosts = GeminiServer
         findVHostCreds = fmap vhostCredentials . (`findVHost` vhosts)
 
 
+-- | Load the Cana config at the given file path.
+loadConfig :: FilePath -> IO (Either String GeminiServer)
+loadConfig path = BS.readFile path >>= parseConfig
+
+
+-- | Parse an in-memory Cana config.
+parseConfig :: BS.ByteString -> IO (Either String GeminiServer)
+parseConfig input = case parse input of
+                      Left err  -> return . Left $ show err
+                      Right dom -> runExceptT $ parseDom dom
+  where
+    parseDom :: Node -> ExceptT String IO GeminiServer
+    parseDom root = do
+      defaultCreds <- findDefaultCreds root
+      let host   = findHost root
+          port   = findPort root
+          vhosts = filter ((== "vhost") . name) $ children root
+      vhosts' <- mapM loadVHost vhosts
+      return $ mkGeminiServer host port defaultCreds vhosts'
+
+    findDefaultCreds root = do
+      defaults <- unwrapMaybe "Could not find <default ...>" .
+        find ((== "default") . name) $ children root
+      certFile <- unwrapMaybe "Default certfile not given" .
+        lookup "certfile" $ attributes defaults
+      keyFile <- unwrapMaybe "Default keyfile not given" .
+        lookup "keyfile" $ attributes defaults
+      liftIO $ loadCredentials (UTF8.toString certFile) (UTF8.toString keyFile)
+
+    findBind root attr = find ((== "bind") . name) (children root)
+          >>= lookup attr . attributes
+    findHost root = UTF8.toString <$> findBind root "host"
+    findPort root = maybe defaultGeminiPort UTF8.toString $ findBind root "port"
+
+    loadVHost :: Node -> ExceptT String IO VirtualHost
+    loadVHost elem = do
+      host <- unwrapMaybe "No host given for vhost" .
+        lookup "match" $ attributes elem
+      certFile <- unwrapMaybe "No certfile given for vhost" .
+        lookup "certfile" $ attributes elem
+      keyFile <- unwrapMaybe "No keyfile given for vhost" .
+        lookup "keyfile" $ attributes elem
+      creds <- liftIO $ loadCredentials (UTF8.toString certFile) (UTF8.toString keyFile)
+      routes <- mapM loadRoute $ filter ((== "mount") . name) (children elem)
+      return VirtualHost
+        { vhostName        = UTF8.toString host
+        , vhostCredentials = creds
+        , vhostRoutes      = routes
+        }
+
+    loadRoute :: Node -> ExceptT String IO Route
+    loadRoute elem = do
+      match <- unwrapMaybe "No route path given" .
+        lookup "match" $ attributes elem
+      let predicate = (=~ match) . uriPath . requestUri
+      handler <- unwrapMaybe "No handler given for route" (listToMaybe $ children elem)
+        >>= makeHandler
+      return (predicate, handler)
+
+    makeHandler :: Node -> ExceptT String IO Handler
+    makeHandler elem = case name elem of
+      "staticfiles" -> do
+        path <- unwrapMaybe "No path for static files given" .
+          lookup "path" $ attributes elem
+        return . staticFiles $ UTF8.toString path
+
+      "runcgi" -> do
+        script <- unwrapMaybe "No script for CGI handler given" .
+          lookup "script" $ attributes elem
+        return $ runCGI (UTF8.toString script) []
+
+      x -> throwE ("No handler called '" ++ UTF8.toString x ++ "' known")
+
+
+-- | Load the credentials.
+--
+-- 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
+
+
 -- | Checks whether a given host matches the given pattern.
 --
 -- This supports wildcards in the pattern, but only as proper parts:
@@ -63,7 +172,7 @@ mkGeminiServer hostName port creds vhosts = GeminiServer
 hostMatches :: String -- ^ The pattern.
             -> String -- ^ The string to check.
             -> Bool
-hostMatches pattern host = matches (prepare pattern) (prepare host)
+hostMatches patt host = matches (prepare patt) (prepare host)
   where
     prepare = reverse . splitList '.'
     -- Base case
diff --git a/src/Cana/Types.hs b/src/Cana/Types.hs
index a271a40..28010d0 100644
--- a/src/Cana/Types.hs
+++ b/src/Cana/Types.hs
@@ -15,6 +15,8 @@ import Control.Monad.Trans.Class
 import Control.Monad.Trans.Reader hiding (asks)
 import Control.Monad.Trans.Except hiding (except)
 
+import Text.Printf
+
 -- | The Cana monad.
 --
 -- This is the monad that the server will run in.
@@ -35,6 +37,13 @@ data GeminiServer = GeminiServer
     , serverVHosts      :: [VirtualHost] -- ^ The virtual hosts on this server.
     }
 
+instance Show GeminiServer where
+  show server = printf
+    "GeminiServer { serverHostName = %v, serverPort = %v, serverVHosts = %v }"
+    (show $ serverHostName server)
+    (show $ serverPort server)
+    (show $ serverVHosts server)
+
 -- | A predicate is a function that defines whether a route should match.
 type Predicate = GeminiRequest -> Bool
 -- | A handler is a function that generates a response for the given request.
@@ -60,3 +69,8 @@ data VirtualHost = VirtualHost
         -- Note that you can add any routes, but the vhost will already do the
         -- host-based pre-filtering.
     }
+
+instance Show VirtualHost where
+  show vhost = printf
+    "VirtualHost { vhostName = %v, routes = [...] }"
+    (show $ vhostName vhost)
diff --git a/src/Cana/Util.hs b/src/Cana/Util.hs
index cd97ace..1f0c798 100644
--- a/src/Cana/Util.hs
+++ b/src/Cana/Util.hs
@@ -5,8 +5,12 @@
 
 module Cana.Util
     ( splitList
+    , mapLeft
+    , unwrapMaybe
     ) where
 
+import Control.Monad.Trans.Except
+
 -- | Split a list on the given element, useful for 'String's.
 --
 -- >>> splitList '.' "foo.bar"
@@ -17,3 +21,20 @@ splitList d = uncurry (:) . foldr step ([], [])
     step c (w, s)
       | c == d    = ([], w:s)
       | otherwise = (c:w, s)
+
+
+-- | Map a function over the left element of an 'Either'.
+--
+-- >>> mapLeft ("Hello, " ++) (Left "World")
+-- Left "Hello, World"
+-- >>> mapLeft ("Hello, " ++) (Right "World")
+-- Right "World"
+mapLeft :: (b -> c) -> Either b a -> Either c a
+mapLeft f (Left x)  = Left (f x)
+mapLeft _ (Right x) = Right x
+
+-- | /Unwraps/ the value of a maybe. If the maybe is 'Nothing', it calls 'throwE'
+-- with the given error message instead.
+unwrapMaybe :: Monad m => b -> Maybe a -> ExceptT b m a
+unwrapMaybe err Nothing  = throwE err
+unwrapMaybe _   (Just x) = return x