Capsule.hs

{-|

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 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 (_::IOException) -> 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