💾 Archived View for gemini.thegonz.net › resumeTest.hs captured on 2022-07-16 at 13:57:02.

View Raw

More Information

⬅️ Previous capture (2022-03-01)

➡️ Next capture (2024-05-10)

-=-=-=-=-=-=-

{-# LANGUAGE OverloadedStrings #-}

module Main where

import Control.Concurrent (threadDelay)
import Data.Default.Class (def)
import Data.Maybe (fromMaybe)
import Data.PEM
import Data.X509
import Data.X509.Validation
import Network.Socket
import Network.TLS
import Network.TLS.Extra.Cipher
import Control.Monad.Trans.Maybe  (MaybeT (..), runMaybeT)

import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as BLC
import qualified Network.Simple.TCP as TCP
import qualified Network.TLS.SessionManager as SM

main = do
    Right cred <- credentialLoadX509 "test.cert" "test.key"
    serve cred "1956"

serve :: Credential
    -> String -- ^Port
    -> IO ()
serve cred port = do
    sessionManager <- SM.newSessionManager SM.defaultConfig
    let params = def
                { serverShared = def
                    { sharedSessionManager = sessionManager
                    , sharedCredentials = Credentials [cred]
                    }
                , serverEarlyDataSize = 1024
                , serverSupported = def { supportedCiphers = gemini_ciphersuite }
                , serverHooks = def
                    { onUnverifiedClientCert = return True
                    , onClientCertificate = \_ -> return CertificateUsageAccept
                    }
                , serverWantClientCert = False
                }
    TCP.serve TCP.HostAny port $ \(sock,_) -> do
        context <- contextNew sock params
        handshake context
        recvData context
        Just info <- contextGetInformation context
        mode <- runMaybeT $ do
                info <- MaybeT $ contextGetInformation context
                MaybeT . return $ infoTLS13HandshakeMode info
        sendData context . BLC.pack $ "20 text/gemini\r\nHandshake type: " <> case mode of
            Just FullHandshake -> "Full handshake.\r\nThis is the most expensive way to make a request. To see if your client supports resuming, refresh this page and see if it uses a different handshake type."
            Just HelloRetryRequest -> "Full handshake with hello retry request.\r\nWeird."
            Just PreSharedKey -> "Pre-shared key.\r\nGood! This is the basic type of TLS resumption, much cheaper than a full handshake. For bonus points, you might consider getting your client to support RTT0 (early data)."
            Just RTT0 -> "RTT0 (early data).\r\nNice. This is the cheapest and fastest way to make a request."
            _ -> "BUG!"
        bye context
        gracefulClose sock 5000

gemini_ciphersuite :: [Cipher]
gemini_ciphersuite =
    [        -- First the PFS + GCM + SHA2 ciphers
      cipher_ECDHE_ECDSA_AES128GCM_SHA256, cipher_ECDHE_ECDSA_AES256GCM_SHA384
    , cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256
    , cipher_ECDHE_RSA_AES128GCM_SHA256, cipher_ECDHE_RSA_AES256GCM_SHA384
    , cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256
    , cipher_DHE_RSA_AES128GCM_SHA256, cipher_DHE_RSA_AES256GCM_SHA384
    , cipher_DHE_RSA_CHACHA20POLY1305_SHA256
    ,        -- Next the PFS + CCM + SHA2 ciphers
      cipher_ECDHE_ECDSA_AES128CCM_SHA256, cipher_ECDHE_ECDSA_AES256CCM_SHA256
    , cipher_DHE_RSA_AES128CCM_SHA256, cipher_DHE_RSA_AES256CCM_SHA256
             -- Next the PFS + CBC + SHA2 ciphers
    , cipher_ECDHE_ECDSA_AES128CBC_SHA256, cipher_ECDHE_ECDSA_AES256CBC_SHA384
    , cipher_ECDHE_RSA_AES128CBC_SHA256, cipher_ECDHE_RSA_AES256CBC_SHA384
    , cipher_DHE_RSA_AES128_SHA256, cipher_DHE_RSA_AES256_SHA256
            -- TLS13 (listed at the end but version is negotiated first)
    , cipher_TLS13_AES128GCM_SHA256
    , cipher_TLS13_AES256GCM_SHA384
    , cipher_TLS13_CHACHA20POLY1305_SHA256
    , cipher_TLS13_AES128CCM_SHA256
    ]