implemented runConnection logic

gemserv.cabal

@@ -45,6 +45,7 @@ test-suite gemserv-test
   type: exitcode-stdio-1.0
   main-is: Spec.hs
   other-modules:
+      Network.GemServ.InternalSpec
       Network.GemServSpec
       Paths_gemserv
   hs-source-dirs:

src/Network/GemServ.hs

@@ -42,12 +42,13 @@ module Network.GemServ (
 
 import Control.Concurrent (forkIO)
 import Control.Exception (IOException, try)
-import Control.Exception.Base (bracket)
+import Control.Exception.Base (bracket, finally)
 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 qualified Data.Connection as C
 import Data.IORef (IORef, newIORef, readIORef, writeIORef)
 import Data.List (find, intercalate)
 import Data.Maybe (fromJust)
@@ -55,10 +56,10 @@ import qualified Data.Text as T
 import Data.Text.Encoding (decodeUtf8')
 import Data.TLSSetting (makeServerParams)
 import Data.X509 (Certificate, CertificateChain (..), getSigned, signedObject)
-import Network.Socket (Socket, close)
+import qualified Network.Socket as S
 import Network.TLS (ServerParams, onClientCertificate, serverHooks)
 import System.IO.Streams.TCP (bindAndListen)
-import System.IO.Streams.TLS (accept)
+import System.IO.Streams.TLS (TLSConnection, accept)
 
 import Network.GemServ.Internal
 import Network.GemServ.Types
@@ -75,7 +76,7 @@ runGemServer settings handler = bracket
     (servConnections settings)
     (fromIntegral $ servPort settings)
   )
-  close
+  S.close
   ( \sock -> do
     params <- makeServerParams
       (servCert settings)
@@ -177,14 +178,15 @@ 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 :: S.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 $
+    Right conn              -> void $ forkIO $ finally
-      readIORef certRef >>= runConnection conn handler
+      (readIORef certRef >>= runConnection conn handler)
+      (C.close conn)
   listenLoop sock params handler
 
 adjustServerParams
@@ -205,6 +207,20 @@ adjustServerParams certRef params = let
   hooks' = hooks { onClientCertificate = certHook' }
   in params { serverHooks = hooks' }
 
+runConnection
+  :: TLSConnection
+  -> GemHandler
+  -> Maybe Certificate
+  -> IO ()
+runConnection conn handler mCert =
+  ( readURL conn >>= \case
+    Nothing -> return $ newGemResponse
+      { respStatus = 59
+      , respMeta   = "bad request"
+      }
+    Just url -> handler (newGemRequest url) { reqCert = mCert }
+  ) >>= sendResponse conn
+
 hexDigits :: String
 hexDigits = ['0'..'9'] ++ ['a'..'f']
 

src/Network/GemServ/Internal.hs

@@ -31,24 +31,28 @@ time.
 -}
 
 module Network.GemServ.Internal (
-  runConnection
+  readURL,
+  sendResponse
 ) where
 
-import Data.X509 (Certificate)
+import Data.Connection (Connection)
-import System.IO.Streams.TLS (TLSConnection)
 
 import Network.GemServ.Types
 
--- | takes a Gemini request from a 'TLSConnection' and replies with
+-- | Reads a 'GemURL' from a 'Connection'
--- the response
+readURL
-runConnection
+  :: Connection a
-  :: TLSConnection
+  -- ^ the connection
-  -- ^ The connection
+  -> IO (Maybe GemURL)
-  -> GemHandler
+readURL = undefined
-  -- ^ The handler that produces the response
+
-  -> Maybe Certificate
+-- | Sends a 'GemResponse' to a 'Connection'
-  -- ^ The client certificate (if available)
+sendResponse
+  :: Connection a
+  -- ^ the connection
+  -> GemResponse
+  -- ^ the response being sent
   -> IO ()
-runConnection = undefined
+sendResponse = undefined
 
 --jl

test/Network/GemServ/InternalSpec.hs

@@ -0,0 +1,30 @@
+{-
+
+gemserv
+
+Cooyright (C) Jonathan Lamothe <jonathan@jlamothe.net>
+
+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.InternalSpec (spec) where
+
+import Test.Hspec (Spec, describe)
+
+spec :: Spec
+spec = describe "Internal" $ return ()
+
+--jl

test/Network/GemServSpec.hs

@@ -24,11 +24,14 @@ module Network.GemServSpec (spec) where
 
 import Test.Hspec (Spec, context, describe, it, shouldBe)
 
+import qualified Network.GemServ.InternalSpec as Internal
+
 import Network.GemServ
 import Network.GemServ.Types
 
 spec :: Spec
 spec = describe "Network.GemServ" $ do
+  Internal.spec
   encodeGemURLSpec
   decodeGemURLSpec
   escapeStringSpec