fix loadCredentials

1. This function used 'fail', which is rather bad - now it returns
   'Either'

2. The function was still hardwired to the specific filenames of the
   first prototypes.

2 files changed, 15 insertions, 17 deletions

diff --git a/src/Cana.hs b/src/Cana.hs
index ca87fa1..2e616ac 100644
--- a/src/Cana.hs
+++ b/src/Cana.hs
@@ -81,12 +81,15 @@ runGeminiServer :: Maybe HostName -- ^ Hostname to bind to.
                 -> IO (Either String ())
 runGeminiServer hostName serviceName credFile keyFile routes = do
   creds <- loadCredentials credFile keyFile
-  let vhost = VirtualHost {
-      vhostName        = "*"
-    , vhostCredentials = creds
-    , vhostRoutes      = routes
-    }
-  runGeminiServer' (mkGeminiServer hostName serviceName creds [vhost])
+  case creds of
+    Left l      -> return $ Left l
+    Right creds -> do
+      let vhost = VirtualHost {
+          vhostName        = "*"
+        , vhostCredentials = creds
+        , vhostRoutes      = routes
+        }
+      runGeminiServer' (mkGeminiServer hostName serviceName creds [vhost])
 
 -- | Run the Gemini server.
 --
diff --git a/src/Cana/Server.hs b/src/Cana/Server.hs
index 9454365..766a371 100644
--- a/src/Cana/Server.hs
+++ b/src/Cana/Server.hs
@@ -95,7 +95,7 @@ parseConfig input = case parse input of
         lookup "certfile" $ attributes defaults
       keyFile <- unwrapMaybe "Default keyfile not given" .
         lookup "keyfile" $ attributes defaults
-      liftIO $ loadCredentials (UTF8.toString certFile) (UTF8.toString keyFile)
+      ExceptT $ loadCredentials (UTF8.toString certFile) (UTF8.toString keyFile)
 
     findBind root attr = find ((== "bind") . name) (children root)
           >>= lookup attr . attributes
@@ -110,7 +110,7 @@ parseConfig input = case parse input of
         lookup "certfile" $ attributes elem
       keyFile <- unwrapMaybe "No keyfile given for vhost" .
         lookup "keyfile" $ attributes elem
-      creds <- liftIO $ loadCredentials (UTF8.toString certFile) (UTF8.toString keyFile)
+      creds <- ExceptT $ loadCredentials (UTF8.toString certFile) (UTF8.toString keyFile)
       routes <- mapM loadRoute $ filter ((== "mount") . name) (children elem)
       return VirtualHost
         { vhostName        = UTF8.toString host
@@ -143,18 +143,13 @@ parseConfig input = case parse input of
 
 
 -- | 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]
+                -> IO (Either String TLS.Credentials) -- ^ The loaded credentials.
+loadCredentials certFile keyFile =
+  fmap (TLS.Credentials . singleton) <$> TLS.credentialLoadX509 certFile keyFile
     where
-      unwrap :: Either String a -> IO a
-      unwrap (Left s) = fail s
-      unwrap (Right x) = pure x
+      singleton x = [x]
 
 
 -- | Checks whether a given host matches the given pattern.