diff --git a/gemserv.cabal b/gemserv.cabal index 5aae760..0ac491a 100644 --- a/gemserv.cabal +++ b/gemserv.cabal @@ -23,6 +23,7 @@ extra-source-files: library exposed-modules: Network.GemServ + Network.GemServ.Internal Network.GemServ.Types other-modules: Paths_gemserv diff --git a/src/Network/GemServ.hs b/src/Network/GemServ.hs index bde9cf0..138e58c 100644 --- a/src/Network/GemServ.hs +++ b/src/Network/GemServ.hs @@ -24,7 +24,11 @@ License along with this program. If not, see -} -{-# LANGUAGE LambdaCase, OverloadedStrings, RecordWildCards #-} +{-# LANGUAGE + LambdaCase, + OverloadedStrings, + ScopedTypeVariables, + RecordWildCards #-} module Network.GemServ ( -- * Running a Gemini Server @@ -36,18 +40,27 @@ module Network.GemServ ( unescapeString ) where +import Control.Concurrent (forkIO) +import Control.Exception (IOException, try) import Control.Exception.Base (bracket) +import Control.Monad (void) import qualified Data.ByteString as BS import Data.ByteString.Builder (charUtf8, stringUtf8, toLazyByteString) import qualified Data.ByteString.Lazy as BSL import Data.Char (chr, ord, toLower) +import Data.IORef (IORef, newIORef, writeIORef) import Data.List (find, intercalate) import Data.Maybe (fromJust) import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8') -import Network.Socket (close) +import Data.TLSSetting (makeServerParams) +import Data.X509 (Certificate, CertificateChain (..), getSigned, signedObject) +import Network.Socket (Socket, close) +import Network.TLS (ServerParams, onClientCertificate, serverHooks) import System.IO.Streams.TCP (bindAndListen) +import System.IO.Streams.TLS (accept) +import Network.GemServ.Internal import Network.GemServ.Types -- | Builds and runs a Gemini server @@ -56,14 +69,20 @@ runGemServer -- ^ The server settings -> GemHandler -- ^ The handler - -> IO () -runGemServer settings _ = bracket + -> IO a +runGemServer settings handler = bracket ( bindAndListen (servConnections settings) (fromIntegral $ servPort settings) ) close - undefined + ( \sock -> do + params <- makeServerParams + (servCert settings) + (servCertChain settings) + (servKey settings) + listenLoop sock params handler + ) -- | Encodes a 'GemURL' into a 'String' encodeGemURL :: GemURL -> String @@ -158,6 +177,33 @@ unescapeString str = case decodeUtf8' $ BS.pack $ toBytes str of toNum ch = fst $ fromJust $ find (\x -> snd x == ch) $ zip [0..] hexDigits +listenLoop :: Socket -> ServerParams -> GemHandler -> IO a +listenLoop sock params handler = do + certRef <- newIORef Nothing + let params' = adjustServerParams certRef params + try (accept params' sock) >>= \case + Left (_ :: IOException) -> return () + Right conn -> void $ forkIO $ runConnection conn handler + listenLoop sock params handler + +adjustServerParams + :: IORef (Maybe Certificate) + -> ServerParams + -> ServerParams +adjustServerParams certRef params = let + hooks = serverHooks params + certHook = onClientCertificate hooks + + certHook' chain = case chain of + CertificateChain [] -> certHook chain + CertificateChain (se:_) -> do + let cert = signedObject $ getSigned se + writeIORef certRef (Just cert) + certHook chain + + hooks' = hooks { onClientCertificate = certHook' } + in params { serverHooks = hooks' } + hexDigits :: String hexDigits = ['0'..'9'] ++ ['a'..'f'] diff --git a/src/Network/GemServ/Internal.hs b/src/Network/GemServ/Internal.hs new file mode 100644 index 0000000..3027783 --- /dev/null +++ b/src/Network/GemServ/Internal.hs @@ -0,0 +1,45 @@ +{-| + +Module : Network.GemServ.Internal +Description : internal functions (do not use) +Copyright : (C) Jonathan Lamothe +License : AGPL-3.0-or-later +Maintainer : jonathan@jlamothe.net +Stability : experimental +Portability : POSIX + +This program is free software: you can redistribute it and/or modify +it under the terms of the GNU Affero General Public License as +published by the Free Software Foundation, either version 3 of the +License, or (at your option) any later version. + +This program is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Affero General Public License for more details. + +You should have received a copy of the GNU Affero General Public +License along with this program. If not, see +. + +-} + +module Network.GemServ.Internal ( + runConnection +) where + +import System.IO.Streams.TLS (TLSConnection) + +import Network.GemServ.Types + +-- | takes a Gemini request from a 'TLSConnection' and replies with +-- the response +runConnection + :: TLSConnection + -- ^ The connection + -> GemHandler + -- ^ The handler that produces the response + -> IO () +runConnection = undefined + +--jl