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 +++++++++++++++++++++++++++++++++++++++++++++++ src/Cana/Monad.hs | 45 +++++++++++ src/Cana/Protocol.hs | 209 +++++++++++++++++++++++++++++++++++++++++++++++++++ src/Cana/Router.hs | 20 +++++ src/Cana/Server.hs | 43 +++++++++++ src/Cana/Types.hs | 43 +++++++++++ 6 files changed, 556 insertions(+) create mode 100644 src/Cana.hs create mode 100644 src/Cana/Monad.hs create mode 100644 src/Cana/Protocol.hs create mode 100644 src/Cana/Router.hs create mode 100644 src/Cana/Server.hs create mode 100644 src/Cana/Types.hs (limited to 'src') 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) diff --git a/src/Cana/Monad.hs b/src/Cana/Monad.hs new file mode 100644 index 0000000..e63e89a --- /dev/null +++ b/src/Cana/Monad.hs @@ -0,0 +1,45 @@ +-- | +-- Module : Cana.Monad +-- +-- This module contains the 'Cana' monad implementation. + + +module Cana.Monad where + +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Trans.Reader hiding (asks) +import qualified Control.Monad.Trans.Reader +import Control.Monad.Trans.Except hiding (except) +import qualified Control.Monad.Trans.Except + +import Cana.Types + +-- | Run a computation in the 'Cana' monad. +runCana :: GeminiServer -> Cana a -> IO (Either String a) +runCana server (Cana r) = runExceptT $ runReaderT r server + +-- | Retrieve the 'GeminiServer' instance out of the 'Cana' monad. +askGeminiServer :: Cana GeminiServer +askGeminiServer = Cana ask + +-- | Retrieve the 'GeminiServer' but apply a function to the value before +-- returning it. +asks :: (GeminiServer -> a) -> Cana a +asks = Cana . Control.Monad.Trans.Reader.asks + +-- | Wrap a fallible value into the 'Cana' monad. +except :: Either String a -> Cana a +except = Cana . lift . Control.Monad.Trans.Except.except + +-- | Fail with the given error value. +throw :: String -> Cana a +throw = Cana . lift . Control.Monad.Trans.Except.throwE + +-- | Log some information. +logInfo :: MonadIO m => String -> m () +logInfo text = liftIO $ putStrLn ("[ INFO] " ++ text) + +-- | Log error information. +logError :: MonadIO m => String -> m () +logError text = liftIO $ putStrLn ("\x1B[31m[ERROR]\x1B[m " ++ text) diff --git a/src/Cana/Protocol.hs b/src/Cana/Protocol.hs new file mode 100644 index 0000000..629353a --- /dev/null +++ b/src/Cana/Protocol.hs @@ -0,0 +1,209 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : Cana.Protocol +-- +-- This module describes base types for interaction with the Gemini protocol. + +module Cana.Protocol + ( + -- * Status codes + StatusCode + , fromInt + , toInt + -- ** Predefined status codes + , codeInput + , codeSensitiveInput + , codeSuccess + , codeRedirectTemporary + , codeRedirectPermanent + , codeTemporaryFailure + , codeServerUnavailable + , codeCGIError + , codeProxyError + , codeSlowDown + , codePermanentFailure + , codeNotFound + , codeGone + , codeProxyRequestRefused + , codeBadRequest + , codeClientCertRequired + , codeCertNotAuthorised + , codeCertNotValid + -- * Requests & Responses + , GeminiRequest(..) + , GeminiResponse(..) + , renderResponse + -- * Various things + , defaultGeminiPort + ) where + +import qualified Data.ByteString.Lazy as B +import Data.ByteString.Builder +import Data.X509 (CertificateChain) +import Network.URI +import Network.Socket (ServiceName) + +-- | A Gemini status code, a two digit integer. +newtype StatusCode = StatusCode Int deriving (Eq, Show, Ord) + +-- | Converts an integer to a status code. +-- +-- Returns 'Nothing' for integers that do not represent a valid status code. +fromInt :: Int -> Maybe StatusCode +fromInt code + | 10 <= code && code <= 99 = Just $ StatusCode code + | otherwise = Nothing + +-- | Extracts the integer value out of a status code. +toInt :: StatusCode -> Int +toInt (StatusCode code) = code + +-- | INPUT status code. +-- +-- This code signals the user that input is expected. The response meta field +-- should provide a user-readable prompt. +codeInput :: StatusCode +codeInput = StatusCode 10 + +-- | SENSITIVE INPUT status code. +-- +-- The same as 'codeInput', but the user input should not be echoed back to the +-- user. +codeSensitiveInput :: StatusCode +codeSensitiveInput = StatusCode 11 + +-- | SUCCESS status code. +-- +-- The request was handled successfully. The response meta field should contain +-- the media MIME type of the response body. +codeSuccess :: StatusCode +codeSuccess = StatusCode 20 + +-- | REDIRECT - TEMPORARY status code. +-- +-- The requested resource was found at a different location. The response meta +-- field should contain the new URL. +codeRedirectTemporary :: StatusCode +codeRedirectTemporary = StatusCode 30 + +-- | REDIRECT - PERMANENT status code. +-- +-- Same as 'codeRedirectTemporary', except that the resource should also be +-- requested through the new URL in the future. +codeRedirectPermanent :: StatusCode +codeRedirectPermanent = StatusCode 31 + +-- | TEMPORARY FAILURE status code. +-- +-- The request has failed, but might succeed in the future. The response meta +-- field may provide additional information to the user. +codeTemporaryFailure :: StatusCode +codeTemporaryFailure = StatusCode 40 + +-- | SERVER UNAVAILABLE status code. +-- +-- The server is unavailable, for example due to overload. +codeServerUnavailable :: StatusCode +codeServerUnavailable = StatusCode 41 + +-- | CGI ERROR status code. +-- +-- The process that generates content dynamically has died. +codeCGIError :: StatusCode +codeCGIError = StatusCode 42 + +-- | PROXY ERROR status code. +-- +-- A proxy request failed. +codeProxyError :: StatusCode +codeProxyError = StatusCode 42 + +-- | SLOW DOWN status code. +-- +-- The client is being rate limited. The response meta field gives the number +-- of seconds that the client has to wait before it can issue the next request. +codeSlowDown :: StatusCode +codeSlowDown = StatusCode 44 + +-- | PERMANENT FAILURE status code. +-- +-- The request has failed and the reason is likely to be permanent. The +-- response meta field can give a readable reason to the user. +codePermanentFailure :: StatusCode +codePermanentFailure = StatusCode 50 + +-- | NOT FOUND status code. +-- +-- The requested resource was not found (but may exist in the future). +codeNotFound :: StatusCode +codeNotFound = StatusCode 51 + +-- | GONE status code. +-- +-- The requested resource is no longer available. +codeGone :: StatusCode +codeGone = StatusCode 52 + +-- | PROXY REQUEST REFUSED status code. +-- +-- The requested resource lies at a different domain which the server does not +-- serve or proxy. +codeProxyRequestRefused :: StatusCode +codeProxyRequestRefused = StatusCode 53 + +-- | BAD REQUEST status code. +-- +-- The client gave a malformed request. +codeBadRequest :: StatusCode +codeBadRequest = StatusCode 59 + +-- | CLIENT CERTIFICATE REQUIRED status code. +-- +-- The server expects a client certificate to be given. The response meta field +-- may give a specific reason why a certificate is required. +codeClientCertRequired :: StatusCode +codeClientCertRequired = StatusCode 60 + +-- | CERTIFICATE NOT AUTHORISED status code. +-- +-- The supplied client certificate is not authorised. +codeCertNotAuthorised :: StatusCode +codeCertNotAuthorised = StatusCode 61 + +-- | CERTIFICATE NOT VALID status code. +-- +-- The given client certificate is invalid. +codeCertNotValid :: StatusCode +codeCertNotValid = StatusCode 62 + +-- | A Gemini request. +-- +-- Gemini requests usually only contain the URI that has been requested, which +-- can be examined with 'requestUri'. +-- +-- If the client sends a certificate, it can be saved in 'requestCert'. +data GeminiRequest = GeminiRequest + { requestUri :: URI -- ^ The requested URI. + , requestCert :: Maybe CertificateChain -- ^ The client certificate, if given. + } deriving (Show, Eq) + +-- | A Gemini response. +data GeminiResponse = GeminiResponse + { responseStatus :: StatusCode -- ^ The response status code. + , responseMeta :: B.ByteString -- ^ The meta information. + , responseData :: B.ByteString -- ^ The actual response. + } + +-- | Render a response to a 'ByteString', suitable to send over a socket. +renderResponse :: GeminiResponse -> B.ByteString +renderResponse rsp = toLazyByteString $ mconcat + [ intDec (toInt $ responseStatus rsp) + , charUtf8 ' ' + , lazyByteString $ responseMeta rsp + , stringUtf8 "\r\n" + , lazyByteString $ responseData rsp + ] + +-- | The default Gemini port, as given in the specification. +defaultGeminiPort :: ServiceName +defaultGeminiPort = "1965" diff --git a/src/Cana/Router.hs b/src/Cana/Router.hs new file mode 100644 index 0000000..1454375 --- /dev/null +++ b/src/Cana/Router.hs @@ -0,0 +1,20 @@ +-- | +-- Module : Cana.Router + +module Cana.Router where + +import Cana.Types +import Cana.Protocol +import Cana.Monad + +import Network.URI + +-- | A predicate that always triggers, e.g. for catch-all routes. +anyRoute :: Predicate +anyRoute = const True + +-- | A predicate that matches the given hostname. +routeHost :: String -> Predicate +routeHost host request = case uriAuthority (requestUri request) of + Nothing -> False + Just auth -> uriRegName auth == host diff --git a/src/Cana/Server.hs b/src/Cana/Server.hs new file mode 100644 index 0000000..3cff44a --- /dev/null +++ b/src/Cana/Server.hs @@ -0,0 +1,43 @@ +-- | +-- Module : Cana.Server +-- +-- This module contains types that are needed for the Cana Gemini server. + +module Cana.Server where + +import Cana.Types + +import Data.Default +import Network.Socket (HostName, ServiceName) +import qualified Network.TLS as TLS +import qualified Network.TLS.Extra.Cipher as TE + +-- | Construct a Gemini server with the given credentials. +-- +-- This ensures that the 'serverParams' are set up sensibly for the Gemini +-- server to work. +mkGeminiServer :: Maybe HostName -> ServiceName -> TLS.Credentials -> [Route] -> GeminiServer +mkGeminiServer hostName port creds routes = GeminiServer + { serverCredentials = creds + , serverParams = params + , serverHostName = hostName + , serverPort = port + , serverRoutes = routes + } + where + params = def + { TLS.serverShared = shared + , TLS.serverSupported = supported + , TLS.serverHooks = hooks + , TLS.serverWantClientCert = True + } + shared = def + { TLS.sharedCredentials = creds + } + supported = def + { TLS.supportedVersions = [ TLS.TLS13, TLS.TLS12 ] + , TLS.supportedCiphers = TE.ciphersuite_default + } + hooks = def + { TLS.onClientCertificate = const $ return TLS.CertificateUsageAccept + } diff --git a/src/Cana/Types.hs b/src/Cana/Types.hs new file mode 100644 index 0000000..250fcc1 --- /dev/null +++ b/src/Cana/Types.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +-- | +-- Module : Cana.Types + +module Cana.Types where + +import Cana.Protocol + +import Network.Socket (HostName, ServiceName) +import qualified Network.TLS as TLS +import qualified Network.TLS.Extra.Cipher as TE + +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Trans.Reader hiding (asks) +import Control.Monad.Trans.Except hiding (except) + +-- | The Cana monad. +-- +-- This is the monad that the server will run in. +newtype Cana a = Cana (ReaderT GeminiServer (ExceptT String IO) a) deriving (Monad, Functor, Applicative, MonadIO) + +-- | The Gemini server information. +-- +-- This has to be loaded and prepared once before the server starts its loop. +-- Note that the server certificate is saved here, so any function that has +-- access to this can also read the private key. +data GeminiServer = GeminiServer + { serverCredentials :: TLS.Credentials -- ^ The server credentials. + , serverParams :: TLS.ServerParams -- ^ The server TLS parameters. + , serverHostName :: Maybe HostName -- ^ The 'HostName' that the server + -- should bind to. + , serverPort :: String -- ^ The port ('ServiceName') that the server + -- should listen on. + , serverRoutes :: [Route] -- ^ The routes that the server handles. + } + +-- | 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. +type Handler = GeminiRequest -> Cana GeminiResponse +-- | A route is a combination of a 'Predicate' and a 'Handler' +type Route = (Predicate, Handler) -- cgit v1.2.3