aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Cana.hs196
-rw-r--r--src/Cana/Monad.hs45
-rw-r--r--src/Cana/Protocol.hs209
-rw-r--r--src/Cana/Router.hs20
-rw-r--r--src/Cana/Server.hs43
-rw-r--r--src/Cana/Types.hs43
6 files changed, 556 insertions, 0 deletions
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)
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-21 18:01:04 +0000