A trivial HTTP server that echoes a fixed string

echo-server.fs

module Resourceful

open System
open System.Net.Sockets
open System.Text
open System.Threading
open System.Threading.Tasks

let response = "HTTP/1.1 200 OK\r\nConnection: Keep-Alive\r\nContent-Length: 5\r\n\r\nhello"
let responseBytes = Encoding.ASCII.GetBytes(response)

type Handler(semaphore : SemaphoreSlim) as this =
    let receiveArgs = new SocketAsyncEventArgs(UserToken = this)
    let sendArgs = new SocketAsyncEventArgs(UserToken = this)
    let buffer = Array.zeroCreate(8192)

    [<DefaultValue>]
    val mutable sock : Socket
        
    [<Literal>]
    let rnrn : int = 0x0a0d0a0d // not portable

    let rec headerEnd (buffer : byte[]) offset total =
        let ix = Array.LastIndexOf(buffer, byte('\n'), total-1, total - offset)
        if ix - 3 < offset
        then None
        else
            if BitConverter.ToInt32(buffer, ix-3) = rnrn
            then Some(ix+1)
            else headerEnd buffer offset (ix - offset - 1)

    let rec handleReceive(args : SocketAsyncEventArgs) =
        let this = args.UserToken :?> Handler
        let received = args.BytesTransferred
        if args.SocketError <> SocketError.Success || received = 0
        then
            (this :> IDisposable).Dispose()
            semaphore.Release() |> ignore
        else
            match headerEnd args.Buffer args.Offset received with
            | Some(headerLength) ->
                if not (this.sock.SendAsync(sendArgs))
                then handleSend(sendArgs)
            | None ->
                // need more data
                let newOffset =  receiveArgs.Offset + received 
                let newCount = receiveArgs.Count - received 
                if newCount = 0
                then
                    // didn't find the end of the headers within the desired count
                    (this :> IDisposable).Dispose()
                    semaphore.Release() |> ignore
                else
                    receiveArgs.SetBuffer(newOffset, newCount)
                    if not (this.sock.ReceiveAsync(receiveArgs))
                    then handleReceive(receiveArgs)

    and handleSend(args : SocketAsyncEventArgs) =
        let this = args.UserToken :?> Handler
        receiveArgs.SetBuffer(0, receiveArgs.Buffer.Length)
        if not (this.sock.ReceiveAsync(receiveArgs))
        then handleReceive(receiveArgs)
    
    do 
        receiveArgs.SetBuffer(buffer, 0, buffer.Length)
        receiveArgs.Completed.Add(handleReceive)
        
        sendArgs.SetBuffer(responseBytes, 0, responseBytes.Length)
        sendArgs.Completed.Add(handleSend)
        
    member public this.handle(sock : Socket) = 
        this.sock <- sock
        if not (this.sock.ReceiveAsync(receiveArgs))
            then handleReceive(receiveArgs)

    interface IDisposable with
        member this.Dispose(): unit = 
            this.sock.Dispose()
            this.sock <- null
            receiveArgs.Dispose()
            sendArgs.Dispose()

type Acceptor(sock : Socket, semaphore : SemaphoreSlim, ct : CancellationToken) as this =
    let args = new SocketAsyncEventArgs(UserToken = this)

    let handleAccept (args : SocketAsyncEventArgs) = 
        let handler = new Handler(semaphore)
        handler.handle(args.AcceptSocket)
        args.AcceptSocket <- null

        let this = args.UserToken :?> Acceptor
        this.accept()

    do
        args.Completed.Add(handleAccept)
   
    member this.accept() =
        semaphore.Wait(ct)
        if not (sock.AcceptAsync(args))
        then handleAccept(args)

    interface IDisposable with
        member this.Dispose() =
            args.Dispose()
    

type Server(maxConnections : int) =
    let semaphore = new SemaphoreSlim(maxConnections)

    member this.Listen (endpoint : Net.EndPoint, ct : CancellationToken) : unit =
        use sock = new Socket(SocketType.Stream, ProtocolType.IP, UseOnlyOverlappedIO = true)
        sock.Bind(endpoint)
        sock.Listen(1000)

        use acceptor = new Acceptor(sock, semaphore, ct)
        acceptor.accept()

        let tcs = TaskCompletionSource<int>()
        ct.Register(fun () -> tcs.SetResult(1)) |> ignore // incomplete
        tcs.Task.Wait()

    interface IDisposable with
        member this.Dispose() =
            semaphore.Dispose()