From 4ef5c4e29379c8eed49f6f24ab5f4a3d73cfe3a5 Mon Sep 17 00:00:00 2001 From: Daniel Schadt 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. --- Cana.cabal | 9 +++- app/Main.hs | 38 ++++++++++----- package.yaml | 2 + src/Cana.hs | 33 ++++++------- src/Cana/Extra.hs | 134 --------------------------------------------------- src/Cana/Handlers.hs | 134 +++++++++++++++++++++++++++++++++++++++++++++++++++ src/Cana/Server.hs | 127 ++++++++++++++++++++++++++++++++++++++++++++---- src/Cana/Types.hs | 14 ++++++ src/Cana/Util.hs | 21 ++++++++ 9 files changed, 336 insertions(+), 176 deletions(-) delete mode 100644 src/Cana/Extra.hs create mode 100644 src/Cana/Handlers.hs 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/Extra.hs deleted file mode 100644 index b7119d6..0000000 --- a/src/Cana/Extra.hs +++ /dev/null @@ -1,134 +0,0 @@ -{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, PartialTypeSignatures #-} --- | --- Module : Cana.Extra --- --- This module contains some extra goodies for writing a Gemini server with --- "Cana", for exmaple a static file server. - -module Cana.Extra - ( -- * High-Level handlers - staticFiles - , runCGI - ) where - -import Cana.Types -import Cana.Protocol -import Cana.Monad - -import Control.Applicative -import Control.Monad -import Control.Monad.Trans.Maybe -import Control.Exception (SomeException, try) - -import Data.String -import Data.Maybe -import qualified Data.Text as T -import System.FilePath -import System.Directory -import System.Process.ByteString.Lazy -import System.Exit (ExitCode(..)) -import Control.Monad.IO.Class -import qualified Data.ByteString.Lazy as BSL -import Data.ByteString.Lazy.Char8 (pack) -import qualified Data.ByteString.Lazy.UTF8 as UTF8 -import Network.URI -import Network.Mime - - --- | Default name for the directory index file. -defaultIndexFile :: String -defaultIndexFile = "index.gmi" - --- | The Gemini MIME type. -geminiMime :: IsString a => a -geminiMime = "text/gemini" - --- | A static file handler. --- --- This handler takes a file path and looks up any request in the given --- directory. -staticFiles :: FilePath -- ^ Base directory where static files are searched. - -> Handler -staticFiles basedir request = do - let reqPath' = uriPath . requestUri $ request - reqPath = if null reqPath' then "/" else sanitize reqPath' - fsPath = basedir ++ reqPath - notFoundResponse = GeminiResponse - { responseStatus = codeNotFound - , responseMeta = "Those are not the capsules you are looking for" - , responseData = "" - } - - dirIndex <- liftIO $ readDirIndex fsPath - fileContent <- liftIO $ readFileContent fsPath - return $ fromMaybe notFoundResponse (dirIndex <|> fileContent) - where - sanitize :: FilePath -> FilePath - sanitize = joinPath - . filter (\p -> dropTrailingPathSeparator p /= "..") - . splitPath - . normalise - - readDirIndex :: FilePath -> IO (Maybe GeminiResponse) - readDirIndex path = runMaybeT $ do - guard $ hasTrailingPathSeparator path - liftIO (doesDirectoryExist path) >>= guard - liftIO (doesFileExist $ path defaultIndexFile) >>= guard - content <- liftIO $ BSL.readFile (path defaultIndexFile) - return GeminiResponse - { responseStatus = codeSuccess - , responseMeta = geminiMime - , responseData = content - } - - readFileContent :: FilePath -> IO (Maybe GeminiResponse) - readFileContent path = runMaybeT $ do - liftIO (doesFileExist path) >>= guard - content <- liftIO $ BSL.readFile path - return GeminiResponse - { responseStatus = codeSuccess - , responseMeta = getMime path - , responseData = content - } - - getMime :: FilePath -> BSL.ByteString - getMime path - | takeExtension path == ".gmi" = geminiMime - | otherwise = BSL.fromStrict - . defaultMimeLookup . T.pack $ takeFileName path - --- | Returns a handler that calls an external script for each request. -runCGI :: FilePath -- ^ CGI script - -> [String] -- ^ Script arguments - -> Handler -runCGI script args request = do - let uri = UTF8.fromString . show . requestUri $ request - (scriptResult :: Either SomeException rest_) <- liftIO . try - $ readProcessWithExitCode script args uri - - (code, stdout, stderr) <- except - $ mapLeft (\e -> "CGI execution error: " ++ show e) scriptResult - - case code of - ExitFailure _ -> do - logError ("CGI script " ++ script ++ " exited with an error:") - liftIO $ BSL.putStr stderr - return invalidResponse - - ExitSuccess -> case parseResponse stdout of - Nothing -> do - logError ("CGI script " ++ script ++ " returned malformed response") - return invalidResponse - Just r -> return r - - where - invalidResponse :: GeminiResponse - invalidResponse = GeminiResponse - { responseStatus = codeCGIError - , responseMeta = "Dynamic content generation has failed" - , responseData = "" - } - - mapLeft :: (a -> b) -> Either a c -> Either b c - mapLeft f (Left x) = Left (f x) - mapLeft _ (Right x) = Right x diff --git a/src/Cana/Handlers.hs b/src/Cana/Handlers.hs new file mode 100644 index 0000000..512ebf3 --- /dev/null +++ b/src/Cana/Handlers.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, PartialTypeSignatures #-} +-- | +-- Module : Cana.Handlers +-- +-- This module contains pre-defined content handlers, like static file handlers +-- or functions to run CGI scripts. + +module Cana.Handlers + ( -- * High-Level handlers + staticFiles + , runCGI + ) where + +import Cana.Types +import Cana.Protocol +import Cana.Monad + +import Control.Applicative +import Control.Monad +import Control.Monad.Trans.Maybe +import Control.Exception (SomeException, try) + +import Data.String +import Data.Maybe +import qualified Data.Text as T +import System.FilePath +import System.Directory +import System.Process.ByteString.Lazy +import System.Exit (ExitCode(..)) +import Control.Monad.IO.Class +import qualified Data.ByteString.Lazy as BSL +import Data.ByteString.Lazy.Char8 (pack) +import qualified Data.ByteString.Lazy.UTF8 as UTF8 +import Network.URI +import Network.Mime + + +-- | Default name for the directory index file. +defaultIndexFile :: String +defaultIndexFile = "index.gmi" + +-- | The Gemini MIME type. +geminiMime :: IsString a => a +geminiMime = "text/gemini" + +-- | A static file handler. +-- +-- This handler takes a file path and looks up any request in the given +-- directory. +staticFiles :: FilePath -- ^ Base directory where static files are searched. + -> Handler +staticFiles basedir request = do + let reqPath' = uriPath . requestUri $ request + reqPath = if null reqPath' then "/" else sanitize reqPath' + fsPath = basedir ++ reqPath + notFoundResponse = GeminiResponse + { responseStatus = codeNotFound + , responseMeta = "Those are not the capsules you are looking for" + , responseData = "" + } + + dirIndex <- liftIO $ readDirIndex fsPath + fileContent <- liftIO $ readFileContent fsPath + return $ fromMaybe notFoundResponse (dirIndex <|> fileContent) + where + sanitize :: FilePath -> FilePath + sanitize = joinPath + . filter (\p -> dropTrailingPathSeparator p /= "..") + . splitPath + . normalise + + readDirIndex :: FilePath -> IO (Maybe GeminiResponse) + readDirIndex path = runMaybeT $ do + guard $ hasTrailingPathSeparator path + liftIO (doesDirectoryExist path) >>= guard + liftIO (doesFileExist $ path defaultIndexFile) >>= guard + content <- liftIO $ BSL.readFile (path defaultIndexFile) + return GeminiResponse + { responseStatus = codeSuccess + , responseMeta = geminiMime + , responseData = content + } + + readFileContent :: FilePath -> IO (Maybe GeminiResponse) + readFileContent path = runMaybeT $ do + liftIO (doesFileExist path) >>= guard + content <- liftIO $ BSL.readFile path + return GeminiResponse + { responseStatus = codeSuccess + , responseMeta = getMime path + , responseData = content + } + + getMime :: FilePath -> BSL.ByteString + getMime path + | takeExtension path == ".gmi" = geminiMime + | otherwise = BSL.fromStrict + . defaultMimeLookup . T.pack $ takeFileName path + +-- | Returns a handler that calls an external script for each request. +runCGI :: FilePath -- ^ CGI script + -> [String] -- ^ Script arguments + -> Handler +runCGI script args request = do + let uri = UTF8.fromString . show . requestUri $ request + (scriptResult :: Either SomeException rest_) <- liftIO . try + $ readProcessWithExitCode script args uri + + (code, stdout, stderr) <- except + $ mapLeft (\e -> "CGI execution error: " ++ show e) scriptResult + + case code of + ExitFailure _ -> do + logError ("CGI script " ++ script ++ " exited with an error:") + liftIO $ BSL.putStr stderr + return invalidResponse + + ExitSuccess -> case parseResponse stdout of + Nothing -> do + logError ("CGI script " ++ script ++ " returned malformed response") + return invalidResponse + Just r -> return r + + where + invalidResponse :: GeminiResponse + invalidResponse = GeminiResponse + { responseStatus = codeCGIError + , responseMeta = "Dynamic content generation has failed" + , responseData = "" + } + + mapLeft :: (a -> b) -> Either a c -> Either b c + mapLeft f (Left x) = Left (f x) + mapLeft _ (Right x) = Right x 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 " . + 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 -- cgit v1.2.3