Jonathan Lamothe
554efdabcb
`listenLoop` was crashing when the client closed the connection during the handshake. How this doesn't qualify as an `IOException` is beyond me.
101 lines
2.9 KiB
Haskell
101 lines
2.9 KiB
Haskell
{-|
|
|
|
|
Module : Network.Gemini.Capsule
|
|
Description : Gemini capsule stuff
|
|
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/>.
|
|
|
|
-}
|
|
|
|
{-# LANGUAGE LambdaCase, ScopedTypeVariables #-}
|
|
|
|
module Network.Gemini.Capsule (
|
|
runGemCapsule
|
|
) where
|
|
|
|
import Control.Concurrent (forkIO)
|
|
import Control.Exception (SomeException, try)
|
|
import Control.Exception.Base (bracket, finally)
|
|
import Control.Monad (void)
|
|
import qualified Data.Connection as C
|
|
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
|
|
import Data.TLSSetting (makeServerParams)
|
|
import Data.X509 (Certificate, CertificateChain (..), getSigned, signedObject)
|
|
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 Network.Gemini.Capsule.Internal
|
|
import Network.Gemini.Capsule.Types
|
|
|
|
-- | Builds and runs a Gemini capsule
|
|
runGemCapsule
|
|
:: GemCapSettings
|
|
-- ^ The capsule settings
|
|
-> GemHandler
|
|
-- ^ The handler
|
|
-> IO a
|
|
runGemCapsule settings handler = bracket
|
|
( bindAndListen
|
|
(capConnections settings)
|
|
(fromIntegral $ capPort settings)
|
|
)
|
|
S.close
|
|
( \sock -> do
|
|
params <- makeServerParams
|
|
(capCert settings)
|
|
(capCertChain settings)
|
|
(capKey settings)
|
|
listenLoop sock params handler
|
|
)
|
|
|
|
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 (_::SomeException) -> return ()
|
|
Right conn -> void $ forkIO $ finally
|
|
(readIORef certRef >>= runConnection conn handler)
|
|
(C.close conn)
|
|
listenLoop sock params handler
|
|
|
|
adjustServerParams
|
|
:: IORef (Maybe Certificate)
|
|
-> ServerParams
|
|
-> ServerParams
|
|
adjustServerParams certRef params = let
|
|
hooks = serverHooks params
|
|
certHook = onClientCertificate hooks
|
|
|
|
certHook' chain = do
|
|
case chain of
|
|
CertificateChain [] -> return ()
|
|
CertificateChain (se:_) -> do
|
|
let cert = signedObject $ getSigned se
|
|
writeIORef certRef (Just cert)
|
|
certHook chain
|
|
|
|
hooks' = hooks { onClientCertificate = certHook' }
|
|
in params { serverHooks = hooks' }
|
|
|
|
--jl
|