Enable SSL/TLS support

Author: ademar

examples/Example/Example.fsproj

@@ -1,7 +1,7 @@
 <?xml version="1.0" encoding="utf-8"?>
 <Project Sdk="Microsoft.NET.Sdk">
   <PropertyGroup>
-    <TargetFrameworks>net9.0</TargetFrameworks>
+    <TargetFramework>net9.0</TargetFramework>
     <OutputType>Exe</OutputType>
     <AssemblyName>Example</AssemblyName>
     <AutoGenerateBindingRedirects>true</AutoGenerateBindingRedirects>

examples/Example/Program.fs

@@ -155,12 +155,13 @@ let app =
     ] //>=> logStructured logger logFormatStructured
 
 open System.Security.Cryptography.X509Certificates
+let cert = X509CertificateLoader.LoadPkcs12FromFile("suave.p12", "easy")
 
 [<EntryPoint>]
 let main argv =
   startWebServer
-    { bindings              = [ HttpBinding.createSimple HTTP "127.0.0.1" 8082
-                              ]
+    { bindings              = [ HttpBinding.createSimple HTTP "127.0.0.1" 8082;
+                                HttpBinding.createSimple (HTTPS cert) "127.0.0.1" 8443 ]
       serverKey             = Utils.Crypto.generateKey HttpRuntime.ServerKeyLength
       errorHandler          = defaultErrorHandler
       listenTimeout         = TimeSpan.FromMilliseconds 2000.
@@ -170,29 +171,8 @@ let main argv =
       mimeTypesMap          = mimeTypes
       homeFolder            = None
       compressedFilesFolder = None
-      //logger                = logger
       cookieSerialiser      = new BinaryFormatterSerialiser()
       hideHeader            = false
       maxContentLength      = 1000000 }
     app
-  0
-
-(*
-// using Suave.OpenSSL
-// also see https://github.com/SuaveIO/suave/issues/291
-// and https://github.com/exira/static-mailer/blob/72fdebf37bafc48ea7277ee4a6b2a758df5c3b3d/src/Program.fs#L28-L31
-open Suave.OpenSSL
-open OpenSSL.Core
-open System.Security.Cryptography.X509Certificates
-
-let cert =
-  let bio = BIO.MemoryBuffer()
-  let cert = System.IO.File.ReadAllBytes "example.pem"
-  bio.Write cert
-  OpenSSL.X509.X509Certificate.FromDER bio
-
-Or using the built-in SSL support:
-  let cert = new X509Certificate2("suave.p12","easy")
-  HttpBinding.createSimple (HTTPS cert) "127.0.0.1" 8443
-
-*)
+  0

src/Suave/Combinators.fs

@@ -784,8 +784,12 @@ module EventSource =
   let (<<.) (out : Connection) (data : string) =
     out.asyncWriteBytes (Encoding.UTF8.GetBytes data)
 
-  let dispatch (out : Connection) : ValueTask<int> =
-    send out ES_EOL_S
+  let dispatch (out : Connection) =
+    task {
+      match! out.transport.write ES_EOL_S with
+      | Ok () -> return ()
+      | Result.Error _ -> return ()
+    }
 
   let comment (out : Connection) (cmt : string) =
     out <<. ": " + cmt + ES_EOL

src/Suave/Combinators.fsi

@@ -1609,7 +1609,7 @@ module EventSource =
 
   /// "If the line is empty (a blank line) - dispatch the event."
   /// Dispatches the event properly to the browser.
-  val dispatch : out:Connection -> ValueTask<int>
+  val dispatch : out:Connection -> Task<unit>
 
   /// "If the line starts with a U+003A COLON character (:) - Ignore the line."
   /// Writes a comment to the stream
@@ -1646,7 +1646,7 @@ module EventSource =
     static member createType : id:string -> data:string -> typ:string -> Message
 
   /// send a message containing data to the output stream
-  val send : out:Connection -> msg:Message -> Task<int  >
+  val send : out:Connection -> msg:Message -> Task<unit>
 
   /// This function composes the passed function f with the hand-shake required
   /// to start a new event-stream protocol session with the browser.

src/Suave/ConnectionFacade.fs

@@ -312,7 +312,7 @@ type ConnectionFacade(connection: Connection, runtime: HttpRuntime, connectionPo
 
   member this.shutdown() =
     connection.lineBufferCount <- 0
-    connection.transport.shutdown()
+    Connection.shutdown connection
     connectionPool.Push(this)
 
   /// The request loop initialises a request with a processor to handle the

src/Suave/DefaultTlsProvider.fs

@@ -37,7 +37,7 @@ module Runtime =
 
   type Protocol =
     | HTTP
-    | HTTPS of obj
+    | HTTPS of System.Security.Cryptography.X509Certificates.X509Certificate
 
     member x.secure =
       match x with
@@ -111,4 +111,4 @@ module Runtime =
     { fieldName    : string
       fileName     : string
       mimeType     : string
-      tempFilePath : string }
+      tempFilePath : string }

src/Suave/Runtime.fs

@@ -29,7 +29,7 @@ module Runtime =
     /// The HTTP protocol is the core protocol
     | HTTP
     /// The HTTP protocol tunneled in a TLS tunnel
-    | HTTPS of obj
+    | HTTPS of System.Security.Cryptography.X509Certificates.X509Certificate
 
     member secure : bool
 
@@ -87,4 +87,4 @@ module Runtime =
     { fieldName    : string
       fileName     : string
       mimeType     : string
-      tempFilePath : string }
+      tempFilePath : string }

src/Suave/Runtime.fsi

@@ -13,7 +13,7 @@ open Suave
 /// and that can be closed.
 type Connection =
   { mutable socketBinding : SocketBinding
-    transport     : TcpTransport
+    transport     : ITransport
     reader     : HttpReader
     pipe : Pipe
     lineBuffer    : byte array
@@ -30,7 +30,9 @@ type Connection =
   member inline this.flush () =
     task {
       if this.lineBufferCount> 0  then
-        let! _ = this.transport.write (new Memory<_>(this.lineBuffer,0,this.lineBufferCount))
+        match! this.transport.write (new Memory<_>(this.lineBuffer,0,this.lineBufferCount)) with
+        | Ok () -> ()
+        | Result.Error _ -> ()
         // Clear the buffer to prevent information leakage
         Array.Clear(this.lineBuffer, 0, this.lineBufferCount)
         this.lineBufferCount <- 0
@@ -45,7 +47,9 @@ type Connection =
         if maxByteCount > this.lineBuffer.Length then
           // Flush current buffer first
           if this.lineBufferCount > 0 then
-            let! _ = this.transport.write (new Memory<_>(this.lineBuffer, 0, this.lineBufferCount))
+            match! this.transport.write (new Memory<_>(this.lineBuffer, 0, this.lineBufferCount)) with
+            | Ok () -> ()
+            | Result.Error _ -> ()
             this.lineBufferCount <- 0
 
           // Use ArrayPool for large strings
@@ -55,14 +59,18 @@ type Connection =
             let mutable bytesUsed = 0
             let mutable completed = false
             this.utf8Encoder.Convert(str.ToCharArray(), 0, str.Length, tempBuffer, 0, maxByteCount, true, &charsUsed, &bytesUsed, &completed)
-            let! _ = this.transport.write (new Memory<_>(tempBuffer, 0, bytesUsed))
+            match! this.transport.write (new Memory<_>(tempBuffer, 0, bytesUsed)) with
+            | Ok () -> ()
+            | Result.Error _ -> ()
             return ()
           finally
             ArrayPool<byte>.Shared.Return(tempBuffer)
 
         elif this.lineBufferCount + maxByteCount > this.lineBuffer.Length then
           // Flush buffer and encode into it
-          let! _ = this.transport.write (new Memory<_>(this.lineBuffer, 0, this.lineBufferCount))
+          match! this.transport.write (new Memory<_>(this.lineBuffer, 0, this.lineBufferCount)) with
+          | Ok () -> ()
+          | Result.Error _ -> ()
           let mutable charsUsed = 0
           let mutable bytesUsed = 0
           let mutable completed = false
@@ -89,19 +97,23 @@ type Connection =
   member inline this.asyncWriteBytes (b : byte[]) =
     task {
     if b.Length > 0 then
-      let! _ = this.transport.write (new Memory<_>(b, 0, b.Length))
-      ()
+      match! this.transport.write (new Memory<_>(b, 0, b.Length)) with
+      | Ok () -> ()
+      | Result.Error _ -> ()
   }
 
   member inline this.asyncWriteBufferedBytes (b : byte[]) =
     task {
       if this.lineBufferCount + b.Length > this.lineBuffer.Length then
         // flush lineBuffer
         if this.lineBufferCount > 0 then
-          let! _ = this.transport.write (new Memory<_>(this.lineBuffer, 0, this.lineBufferCount))
-          ()
+          match! this.transport.write (new Memory<_>(this.lineBuffer, 0, this.lineBufferCount)) with
+          | Ok () -> ()
+          | Result.Error _ -> ()
         // don't waste time buffering here
-        let! _ =  this.transport.write (new Memory<_>(b, 0, b.Length))
+        match! this.transport.write (new Memory<_>(b, 0, b.Length)) with
+        | Ok () -> ()
+        | Result.Error _ -> ()
         this.lineBufferCount <- 0
       else
         Buffer.BlockCopy(b, 0, this.lineBuffer,this.lineBufferCount, b.Length)
@@ -143,4 +155,15 @@ module Connection =
     cn.transport.read buf
 
   let inline send (cn :Connection) (buf : ByteSegment) =
-    cn.transport.write buf
+    task {
+      match! cn.transport.write buf with
+      | Ok () -> return Ok ()
+      | Result.Error e -> return Result.Error e
+    }
+
+  let inline shutdown (cn : Connection) =
+    task {
+      match! cn.transport.shutdown() with
+      | Ok () -> ()
+      | Result.Error _ -> ()
+    }

src/Suave/Sockets/Connection.fs

@@ -50,7 +50,14 @@ module Aux =
 
 // this guy can live inside the connection actually
 [<AllowNullLiteral>]
-type HttpReader(transport : TcpTransport, lineBuffer : byte array, pipe: Pipe, cancellationToken) =
+type HttpReader(transportObj : obj, lineBuffer : byte array, pipe: Pipe, cancellationToken) =
+
+  let transport = 
+    match transportObj with
+    | :? ITransport as t -> t
+    | :? TcpTransport as tcp -> tcp :> ITransport
+    | :? SslTransport as ssl -> ssl :> ITransport
+    | _ -> failwith "Invalid transport type"
 
   let mutable running : bool = true
   let mutable dirty : bool = false
@@ -67,13 +74,16 @@ type HttpReader(transport : TcpTransport, lineBuffer : byte array, pipe: Pipe, c
 
   member x.readMoreData () = task {
     let buff = pipe.Writer.GetMemory()
-    let! x = transport.read buff
-    if x > 0 then
-      pipe.Writer.Advance(x)
-      let! flushResult = pipe.Writer.FlushAsync(cancellationToken)
-      return Ok()
-    else
-      return Result.Error (Error.ConnectionError "no more data")
+    match! transport.read buff with
+    | Ok bytesRead ->
+      if bytesRead > 0 then
+        pipe.Writer.Advance(bytesRead)
+        let! flushResult = pipe.Writer.FlushAsync(cancellationToken)
+        return Ok()
+      else
+        return Result.Error (Error.ConnectionError "no more data")
+    | Result.Error e ->
+      return Result.Error e
     }
 
   member x.getData () = task{