{-|

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 (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

-- | Builds and runs a Gemini capsule
runGemCapsule
  :: GemCapSettings
  -- ^ The capsule settings
  -> GemHandler
  -- ^ The handler
  -> 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' }

--jl