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.

8 files changed, 206 insertions, 46 deletions

diff --git a/Cana.cabal b/Cana.cabal
index 2d238cf..e81c75a 100644
--- a/Cana.cabal
+++ b/Cana.cabal
@@ -29,12 +29,13 @@ flag static
 library
   exposed-modules:
       Cana
-      Cana.Extra
+      Cana.Handlers
       Cana.Monad
       Cana.Protocol
       Cana.Router
       Cana.Server
       Cana.Types
+      Cana.Util
   other-modules:
       Paths_Cana
   hs-source-dirs:
@@ -49,6 +50,7 @@ library
     , network
     , network-uri
     , process-extras
+    , regex-tdfa
     , stringsearch
     , text
     , tls
@@ -56,6 +58,7 @@ library
     , utf8-string
     , x509
     , x509-store
+    , xeno
   default-language: Haskell2010
 
 executable Cana-exe
@@ -75,6 +78,7 @@ executable Cana-exe
     , network
     , network-uri
     , process-extras
+    , regex-tdfa
     , stringsearch
     , text
     , tls
@@ -82,6 +86,7 @@ executable Cana-exe
     , utf8-string
     , x509
     , x509-store
+    , xeno
   if flag(static)
     ghc-options: -threaded -rtsopts -with-rtsopts=-N -static -O0 -optl-fuse-ld=bfd
     cc-options: -static
@@ -109,6 +114,7 @@ test-suite Cana-test
     , network
     , network-uri
     , process-extras
+    , regex-tdfa
     , stringsearch
     , text
     , tls
@@ -116,4 +122,5 @@ test-suite Cana-test
     , utf8-string
     , x509
     , x509-store
+    , xeno
   default-language: Haskell2010
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
diff --git a/package.yaml b/package.yaml
index 69fed4e..091eadb 100644
--- a/package.yaml
+++ b/package.yaml
@@ -36,6 +36,8 @@ dependencies:
 - process-extras
 - stringsearch
 - utf8-string
+- xeno
+- regex-tdfa
 
 library:
   source-dirs: src
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