diff --git a/gemserv.cabal b/gemserv.cabal index 87a2cd2..9ca37cc 100644 --- a/gemserv.cabal +++ b/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: diff --git a/src/Network/GemServ.hs b/src/Network/GemServ.hs index 2302572..12e81a0 100644 --- a/src/Network/GemServ.hs +++ b/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 $ - readIORef certRef >>= runConnection conn handler + Right conn -> void $ forkIO $ finally + (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'] diff --git a/src/Network/GemServ/Internal.hs b/src/Network/GemServ/Internal.hs index 2753c5d..ae3af2b 100644 --- a/src/Network/GemServ/Internal.hs +++ b/src/Network/GemServ/Internal.hs @@ -31,24 +31,28 @@ time. -} module Network.GemServ.Internal ( - runConnection + readURL, + sendResponse ) where -import Data.X509 (Certificate) -import System.IO.Streams.TLS (TLSConnection) +import Data.Connection (Connection) 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 - -> Maybe Certificate - -- ^ The client certificate (if available) +-- | Reads a 'GemURL' from a 'Connection' +readURL + :: Connection a + -- ^ the connection + -> IO (Maybe GemURL) +readURL = undefined + +-- | Sends a 'GemResponse' to a 'Connection' +sendResponse + :: Connection a + -- ^ the connection + -> GemResponse + -- ^ the response being sent -> IO () -runConnection = undefined +sendResponse = undefined --jl diff --git a/test/Network/GemServ/InternalSpec.hs b/test/Network/GemServ/InternalSpec.hs new file mode 100644 index 0000000..d8eda25 --- /dev/null +++ b/test/Network/GemServ/InternalSpec.hs @@ -0,0 +1,30 @@ +{- + +gemserv + +Cooyright (C) Jonathan Lamothe + +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.InternalSpec (spec) where + +import Test.Hspec (Spec, describe) + +spec :: Spec +spec = describe "Internal" $ return () + +--jl diff --git a/test/Network/GemServSpec.hs b/test/Network/GemServSpec.hs index b9c90e7..14de639 100644 --- a/test/Network/GemServSpec.hs +++ b/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