diff options
| -rw-r--r-- | Cana.cabal | 9 | ||||
| -rw-r--r-- | app/Main.hs | 38 | ||||
| -rw-r--r-- | package.yaml | 2 | ||||
| -rw-r--r-- | src/Cana.hs | 33 | ||||
| -rw-r--r-- | src/Cana/Handlers.hs (renamed from src/Cana/Extra.hs) | 8 | ||||
| -rw-r--r-- | src/Cana/Server.hs | 127 | ||||
| -rw-r--r-- | src/Cana/Types.hs | 14 | ||||
| -rw-r--r-- | src/Cana/Util.hs | 21 |
8 files changed, 206 insertions, 46 deletions
@@ -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 |