From 84ca6df46909d39585d96c555b431020f1fbf9c5 Mon Sep 17 00:00:00 2001 From: Daniel Schadt Date: Mon, 28 Jun 2021 00:05:53 +0200 Subject: Initial commit This is a working version that can serve pages, yay! A lot of features still missing though, as well as proper package metadata. --- src/Cana.hs | 196 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 196 insertions(+) create mode 100644 src/Cana.hs (limited to 'src/Cana.hs') diff --git a/src/Cana.hs b/src/Cana.hs new file mode 100644 index 0000000..5822ccb --- /dev/null +++ b/src/Cana.hs @@ -0,0 +1,196 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : Cana +-- License : BSD3 +-- +-- "Cana" is a library implementing a [Project +-- Gemini](https://gemini.circumlunar.space/docs/specification.html) server. +-- The main goal of "Cana" is to provide a simple way for other applications to +-- run a Gemini server, as it can be as simple as a few lines of code: +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > module Main where +-- > +-- > import Cana +-- > import Cana.Protocol +-- > import Cana.Router +-- > +-- > defaultResponse :: GeminiResponse +-- > defaultResponse = GeminiResponse +-- > { responseStatus = codeSuccess +-- > , responseMeta = "text/gemini" +-- > , responseData = "# Hello World\nThis page was served by Cana." +-- > } +-- > +-- > main :: IO () +-- > main = runGeminiServer Nothing defaultGeminiPort "certificate.crt" "private.key" +-- > [ (anyRoute, const $ return defaultResponse) +-- > ] +-- +-- Note that the module is split in a few different submodules: +-- +-- * "Cana.Server" contains the server settings setup function. +-- * "Cana.Monad" contains function for working with the 'Cana' monad. +-- * "Cana.Types" defines all necessary types. +-- * "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. + +module Cana + ( -- * High-Level API + runGeminiServer + -- * Low-Level API + , loadCredentials + , canaServer + , canaClient + , writeResponse + ) where + +import Cana.Server +import Cana.Monad +import Cana.Types +import Cana.Protocol +import Cana.Router + +import Data.List +import Control.Monad.IO.Class +import Control.Concurrent (forkFinally) +import qualified Control.Exception as E +import Control.Monad (unless, forever, void) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Char8 as C +import Network.Socket +import Network.URI + +import qualified Network.TLS as TLS + +-- | Run the Gemini server. +-- +-- This is your one-stop-shop to quickly get a Gemini server running. +-- +-- If you need finer grained control, check the other functions defined in this +-- module. +runGeminiServer :: Maybe HostName -- ^ Hostname to bind to. + -> ServiceName -- ^ Service name to listen on. + -> FilePath -- ^ Certificate key file. + -> FilePath -- ^ Private key file. + -> [Route] -- ^ Server routes. + -> IO () +runGeminiServer hostName serviceName credFile keyFile routes = do + creds <- loadCredentials credFile keyFile + result <- runCana (mkGeminiServer hostName serviceName creds routes) canaServer + case result of + Right _ -> return () + Left s -> fail s + +-- | 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 + +-- | Run the actual Gemini server. +-- +-- Note that the server parameters are available through the 'Cana' monad, so +-- you have to use 'runCana' in combination with 'mkGeminiServer' to set up the +-- correct parameters. +canaServer :: Cana () +canaServer = do + server <- askGeminiServer + liftIO $ runTCPServer (serverHostName server) (serverPort server) (handleClient server) + where + handleClient server connection = do + result <- runCana server (canaClient connection) + case result of + Right _ -> pure () + Left s -> logError s + +-- | Handler function for a single Gemini client. +-- +-- This function sets up the TLS context, reads the request and computes the +-- reply. This function should be called with 'forkFinally' to not block other +-- clients. +-- +-- If you have a listening socket already set up, this is the function that you +-- want to use in order to handle a single Gemini client connection. +canaClient :: Socket -> Cana () +canaClient socket = do + params <- asks serverParams + -- Set up TLS context + context <- TLS.contextNew socket params + TLS.handshake context + -- Parse request + clientCert <- liftIO $ TLS.getClientCertificateChain context + request <- BS.takeWhile (\c -> c /= 10 && c /= 13) <$> TLS.recvData context + uri <- case parseURI $ C.unpack request of + Just u -> pure u + Nothing -> do + writeResponse context $ GeminiResponse + { responseStatus = codeBadRequest + , responseMeta = BSL.empty + , responseData = BSL.empty + } + throw "Malformed client request" + -- Acquire resource + logInfo ("Request: " ++ show uri) + let geminiRequest = GeminiRequest { + requestUri = uri + , requestCert = clientCert + } + route <- findRoute geminiRequest + case route of + Just r -> do + response <- r geminiRequest + writeResponse context response + Nothing -> do + writeResponse context $ GeminiResponse + { responseStatus = codeNotFound + , responseMeta = "" + , responseData = "" + } + +-- | Render a response and write it to the TLS encrypted socket. +writeResponse :: TLS.Context -> GeminiResponse -> Cana () +writeResponse context = TLS.sendData context . renderResponse + +-- | Find the fitting route for the given request. +findRoute :: GeminiRequest -> Cana (Maybe Handler) +findRoute req = do + routes <- asks serverRoutes + return $ snd <$> find (\(pred, _) -> pred req) routes + +-- | Run a TCP server. +-- +-- Every client is forked with 'forkFinally'. +-- +-- (Taken from the "network-run" package.) +runTCPServer :: Maybe HostName -> ServiceName -> (Socket -> IO a) -> IO a +runTCPServer mhost port server = withSocketsDo $ do + addr <- resolve + E.bracket (open addr) close loop + where + resolve = do + let hints = defaultHints { + addrFlags = [AI_PASSIVE] + , addrSocketType = Stream + } + head <$> getAddrInfo (Just hints) mhost (Just port) + open addr = do + sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) + setSocketOption sock ReuseAddr 1 + withFdSocket sock setCloseOnExecIfNeeded + bind sock $ addrAddress addr + listen sock 1024 + return sock + loop sock = forever $ do + (conn, _peer) <- accept sock + void $ forkFinally (server conn) (const $ gracefulClose conn 5000) -- cgit v1.2.3