Skip to content

Instantly share code, notes, and snippets.

@panesofglass

panesofglass/F# WebSockets

Forked from sgtz/F# WebSockets
Created July 21, 2014 22:44
Show Gist options
  • Save panesofglass/03589f24f14f7c1e5899 to your computer and use it in GitHub Desktop.
Save panesofglass/03589f24f14f7c1e5899 to your computer and use it in GitHub Desktop.
Download ZIP

Revisions

  1. @sgtz sgtz revised this gist Jul 21, 2014. 1 changed file with 63 additions and 0 deletions.
    63 changes: 63 additions & 0 deletions index.html
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,63 @@
    <html>
    <head>
    <script>
    // instead of using jQuery
    function $(id) { return document.getElementById(id); };
    var ws = new WebSocket("ws://localhost:1900/timer");
    ws.onerror = function(ev){
    $('serverStatus').innerHTML = 'WebSocket Status: Error';
    };
    ws.onabort = function() {
    $('serverStatus').innerHTML = 'WebSocket Status: Abort';
    };
    ws.onopen = function() {
    $('serverStatus').innerHTML = 'WebSocket Status: Socket Open';
    alert("Opened"); };
    ws.onclose = function () {
    $('serverStatus').innerHTML = 'WebSocket Status: Socket Closed';
    alert("Closed");
    };
    ws.onmessage = function (evt) {
    var date = eval('(' + evt.data + ')');
    $('hour').innerHTML = date.hour;
    $('minute').innerHTML = date.minute;
    $('second').innerHTML = date.second;
    };
    </script>
    <style type="text/css">
    table, td, th {
    font-family: "Trebuchet MS", Arial, Helvetica, sans-serif;
    border: 1px solid #A7C942;
    padding: 3px 7px 2px 7px;
    text-align: center;
    }

    td {
    font-weight: bold;
    font-size: 20px;
    }

    th {
    font-size: 14px;
    font-style: italic;
    background-color: #A7C942;
    color: white;
    }
    </style>
    </head>
    <body>
    <p>Server Status:</p><p id="serverStatus"></p>
    <table>
    <tr>
    <th>Hour</th>
    <th>Minute</th>
    <th>Second</th>
    </tr>
    <tr>
    <td id="hour"></td>
    <td id="minute"></td>
    <td id="second"></td>
    </tr>
    </table>
    </body>
    </html>
  2. @sgtz sgtz created this gist Jul 21, 2014.
    196 changes: 196 additions & 0 deletions F# WebSockets
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,196 @@
    namespace WebSocket

    // Appache 2.0 license

    // References:
    // [1] Proposed WebSockets Spec December 2011 http://tools.ietf.org/html/rfc6455
    // [2] John McCutchan (Google Dart Team Member) http://www.altdevblogaday.com/2012/01/23/writing-your-own-websocket-server/
    // [3] A pretty good Python implemenation by mrrrgn https://github.com/mrrrgn/websocket-data-frame-encoder-decoder/blob/master/frame.py
    // [4] WebSockets Organising body http://www.websocket.org/echo.html
    // [5] AndrewNewcomb's Gist (starting point) https://gist.github.com/AndrewNewcomb/711664
    // [6] C# version (Vladimir's starting point?) http://nugget.codeplex.com
    // [7] VLADIMIR MATVEEV http://v2matveev.blogspot.com/2010/04/mailboxprocessors-practical-application.html
    // [8] Matt Moloney's Frame Implementation https://gist.github.com/moloneymb/18959a56c10beb907608

    // Disclaimer: very early stages of refactoring + still hacky

    open System
    open System.IO
    open System.Net
    open System.Net.Sockets
    open System.Text
    open System.Threading
    open System.Runtime.Serialization
    open System.Security.Cryptography

    module ServerUtil =

    let guid6455 = "258EAFA5-E914-47DA-95CA-C5AB0DC85B11"

    /// headers can occur in any order (See 1.3 in [1])
    let isWebSocketsUpgrade (lines: string array) =
    [| "GET /timer HTTP/1.1"; "Upgrade: websocket"; "Connection: Upgrade"|]
    |> Array.map(fun x->lines |> Array.exists(fun y->x.ToLower()=y.ToLower()))
    |> Array.reduce(fun x y->x && y)

    /// see: [1]
    let calcWSAccept6455 (secWebSocketKey:string) =
    let ck = secWebSocketKey + guid6455
    let sha1 = SHA1CryptoServiceProvider.Create()
    let hashBytes = ck |> Encoding.ASCII.GetBytes |> sha1.ComputeHash
    let Sec_WebSocket_Accept = hashBytes |> Convert.ToBase64String
    Sec_WebSocket_Accept

    let createAcceptString6455 acceptCode =
    "HTTP/1.1 101 Switching Protocols\r\n" +
    "Upgrade: websocket\r\n" +
    "Connection: Upgrade\r\n" +
    "Sec-WebSocket-Accept: " + acceptCode + "\r\n"
    + "\r\n"

    let getKey key arr =
    try
    let item = (Array.find (fun (s:String) -> s.StartsWith(key)) arr)
    item.Substring key.Length
    with
    | _ -> ""

    let makeFrame_ShortTxt (P:byte array) =
    let message = new MemoryStream()
    try
    message.WriteByte(byte 0x81) // see 5.6 & 11.8 in [1]. See [2], and [3]
    message.WriteByte(byte P.Length) // assume length < 127 bytes. as yet, no implementation of masking, extended payload length, or the mask
    message.Write(P,0,P.Length) // TODO: cobine with [8]
    message.ToArray()
    finally
    message.Close()


    open ServerUtil

    [<DataContract>]
    type Time =
    { [<DataMember(Name = "hour")>] mutable Hour : int
    [<DataMember(Name = "minute")>] mutable Minute : int
    [<DataMember(Name = "second")>] mutable Second : int }
    static member New(dt : DateTime) = {Hour = dt.Hour; Minute = dt.Minute; Second = dt.Second}

    type Msg =
    | Connect of MailboxProcessor<Time>
    | Disconnect of MailboxProcessor<Time>
    | Tick of Time

    module WebSocketServer =

    let port = 1900
    let ipAddress = IPAddress.Loopback.ToString()
    let origin = "http://localhost"

    let startMailboxProcessor ct f = MailboxProcessor.Start(f, cancellationToken = ct)

    let timer (ctrl : MailboxProcessor<Msg>) interval = async {
    while true do
    do! Async.Sleep interval
    ctrl.Post(Tick <| Time.New(DateTime.Now))
    }

    let runController (ct : CancellationToken) =
    startMailboxProcessor ct (fun (inbox : MailboxProcessor<Msg>) ->
    let listeners = new ResizeArray<_>()
    async {
    while not ct.IsCancellationRequested do
    let! msg = inbox.Receive()
    match msg with
    | Connect l ->
    Console.WriteLine "Connect"
    listeners.Add(l)
    | Disconnect l ->
    Console.WriteLine "Disconnect"
    listeners.Remove(l) |> ignore
    | Tick msg -> listeners.ForEach(fun l -> l.Post msg)
    }
    )

    let runWorker (tcp : TcpClient) (ctrl : MailboxProcessor<Msg>) ct =

    ignore <| startMailboxProcessor ct (fun (inbox : MailboxProcessor<Time>) ->
    let rec handshake = async {
    let ns = tcp.GetStream()
    let bytes = Array.create tcp.ReceiveBufferSize (byte 0)
    let bytesReadCount = ns.Read (bytes, 0, bytes.Length)

    if bytesReadCount > 8 then
    let lines = bytes.[..(bytesReadCount-9)]
    |> System.Text.UTF8Encoding.UTF8.GetString
    |> fun hs->hs.Split([|"\r\n"|], StringSplitOptions.RemoveEmptyEntries)
    match isWebSocketsUpgrade lines with
    | true ->
    let acceptStr =
    (getKey "Sec-WebSocket-Key:" lines
    ).Substring(1) // skip space
    |> calcWSAccept6455
    |> createAcceptString6455
    Console.WriteLine acceptStr // debug
    do! ns.AsyncWrite <| Encoding.ASCII.GetBytes acceptStr
    return! run ns
    | _ ->
    tcp.Close() // validation failed - close connection
    else
    tcp.Close() // validation failed - close connection
    }
    and run (ns : NetworkStream) = async {
    let json = System.Runtime.Serialization.Json.DataContractJsonSerializer(typeof<Time>)
    ctrl.Post(Connect inbox)
    try
    while not ct.IsCancellationRequested do
    let! time = inbox.Receive()

    let payload = new MemoryStream()
    json.WriteObject(payload, time)

    let df = makeFrame_ShortTxt <| payload.ToArray()
    ns.Write(df,0,df.Length)

    finally
    ns.Close()
    ctrl.Post(Disconnect inbox)
    }
    handshake
    )

    let runRequestDispatcher () =
    let listener = new TcpListener(IPAddress.Parse(ipAddress), port)
    let cts = new CancellationTokenSource()
    let token = cts.Token

    let controller = runController token
    Async.Start (timer controller 1000, token)

    let main = async {
    try
    listener.Start(10)
    while not cts.IsCancellationRequested do
    let! client = Async.FromBeginEnd(listener.BeginAcceptTcpClient, listener.EndAcceptTcpClient)
    //client.NoDelay <- true
    runWorker client controller token
    finally
    listener.Stop()
    }

    Async.Start(main, token)

    { new IDisposable with member x.Dispose() = cts.Cancel()}

    let start() =
    let dispose = runRequestDispatcher ()
    printfn "press any key to stop..."
    Console.ReadKey() |> ignore
    dispose.Dispose()

    module Program =

    [<EntryPoint>]
    let main argv =
    //System.Threading.Server.runRequestDispatcher()
    WebSocketServer.start()
    0 // return an integer exit code