{-# LANGUAGE LambdaCase, ScopedTypeVariables #-}
module Network.Gemini.Capsule (
runGemCapsule
) where
import Control.Concurrent (forkIO)
import Control.Exception (IOException, 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
runGemCapsule
:: GemCapSettings
-> GemHandler
-> IO a
runGemCapsule :: GemCapSettings -> GemHandler -> IO a
runGemCapsule GemCapSettings
settings GemHandler
handler = IO Socket -> (Socket -> IO ()) -> (Socket -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
( Int -> PortNumber -> IO Socket
bindAndListen
(GemCapSettings -> Int
capConnections GemCapSettings
settings)
(Word16 -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> PortNumber) -> Word16 -> PortNumber
forall a b. (a -> b) -> a -> b
$ GemCapSettings -> Word16
capPort GemCapSettings
settings)
)
Socket -> IO ()
S.close
( \Socket
sock -> do
ServerParams
params <- FilePath -> [FilePath] -> FilePath -> IO ServerParams
makeServerParams
(GemCapSettings -> FilePath
capCert GemCapSettings
settings)
(GemCapSettings -> [FilePath]
capCertChain GemCapSettings
settings)
(GemCapSettings -> FilePath
capKey GemCapSettings
settings)
Socket -> ServerParams -> GemHandler -> IO a
forall a. Socket -> ServerParams -> GemHandler -> IO a
listenLoop Socket
sock ServerParams
params GemHandler
handler
)
listenLoop :: S.Socket -> ServerParams -> GemHandler -> IO a
listenLoop :: Socket -> ServerParams -> GemHandler -> IO a
listenLoop Socket
sock ServerParams
params GemHandler
handler = do
IORef (Maybe Certificate)
certRef <- Maybe Certificate -> IO (IORef (Maybe Certificate))
forall a. a -> IO (IORef a)
newIORef Maybe Certificate
forall a. Maybe a
Nothing
let params' :: ServerParams
params' = IORef (Maybe Certificate) -> ServerParams -> ServerParams
adjustServerParams IORef (Maybe Certificate)
certRef ServerParams
params
IO TLSConnection -> IO (Either IOException TLSConnection)
forall e a. Exception e => IO a -> IO (Either e a)
try (ServerParams -> Socket -> IO TLSConnection
accept ServerParams
params' Socket
sock) IO (Either IOException TLSConnection)
-> (Either IOException TLSConnection -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left (IOException
_::IOException) -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Right TLSConnection
conn -> IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
finally
(IORef (Maybe Certificate) -> IO (Maybe Certificate)
forall a. IORef a -> IO a
readIORef IORef (Maybe Certificate)
certRef IO (Maybe Certificate) -> (Maybe Certificate -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TLSConnection -> GemHandler -> Maybe Certificate -> IO ()
forall a. Connection a -> GemHandler -> Maybe Certificate -> IO ()
runConnection TLSConnection
conn GemHandler
handler)
(TLSConnection -> IO ()
forall a. Connection a -> IO ()
C.close TLSConnection
conn)
Socket -> ServerParams -> GemHandler -> IO a
forall a. Socket -> ServerParams -> GemHandler -> IO a
listenLoop Socket
sock ServerParams
params GemHandler
handler
adjustServerParams
:: IORef (Maybe Certificate)
-> ServerParams
-> ServerParams
adjustServerParams :: IORef (Maybe Certificate) -> ServerParams -> ServerParams
adjustServerParams IORef (Maybe Certificate)
certRef ServerParams
params = let
hooks :: ServerHooks
hooks = ServerParams -> ServerHooks
serverHooks ServerParams
params
certHook :: CertificateChain -> IO CertificateUsage
certHook = ServerHooks -> CertificateChain -> IO CertificateUsage
onClientCertificate ServerHooks
hooks
certHook' :: CertificateChain -> IO CertificateUsage
certHook' CertificateChain
chain = do
case CertificateChain
chain of
CertificateChain [] -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
CertificateChain (SignedExact Certificate
se:[SignedExact Certificate]
_) -> do
let cert :: Certificate
cert = Signed Certificate -> Certificate
forall a. (Show a, Eq a, ASN1Object a) => Signed a -> a
signedObject (Signed Certificate -> Certificate)
-> Signed Certificate -> Certificate
forall a b. (a -> b) -> a -> b
$ SignedExact Certificate -> Signed Certificate
forall a. (Show a, Eq a, ASN1Object a) => SignedExact a -> Signed a
getSigned SignedExact Certificate
se
IORef (Maybe Certificate) -> Maybe Certificate -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe Certificate)
certRef (Certificate -> Maybe Certificate
forall a. a -> Maybe a
Just Certificate
cert)
CertificateChain -> IO CertificateUsage
certHook CertificateChain
chain
hooks' :: ServerHooks
hooks' = ServerHooks
hooks { onClientCertificate :: CertificateChain -> IO CertificateUsage
onClientCertificate = CertificateChain -> IO CertificateUsage
certHook' }
in ServerParams
params { serverHooks :: ServerHooks
serverHooks = ServerHooks
hooks' }