diff options
| -rw-r--r-- | src/Cana.hs | 15 | ||||
| -rw-r--r-- | src/Cana/Server.hs | 17 |
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. |