implemented more logic for runGemServer

gemserv.cabal

@@ -23,6 +23,7 @@ extra-source-files:
 library
   exposed-modules:
       Network.GemServ
+      Network.GemServ.Internal
       Network.GemServ.Types
   other-modules:
       Paths_gemserv

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 ()
+  -> IO a
-runGemServer settings _ = bracket
+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']
 

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
+<https://www.gnu.org/licenses/>.
+
+-}
+
+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