PageRenderTime 59ms CodeModel.GetById 25ms RepoModel.GetById 0ms app.codeStats 1ms

/src/lib/fracture/TcpServer.fs

http://github.com/fractureio/fracture
F# | 145 lines | 106 code | 20 blank | 19 comment | 14 complexity | 3942d4eabd1703bab042185f9bee7ef2 MD5 | raw file
Possible License(s): Apache-2.0, CC-BY-SA-3.0, GPL-2.0
  1. namespace Fracture
  2. open System
  3. open System.Diagnostics
  4. open System.Net
  5. open System.Net.Sockets
  6. open System.Collections.Generic
  7. open System.Collections.Concurrent
  8. open SocketExtensions
  9. open Common
  10. open Threading
  11. ///Creates a new TcpServer using the specified parameters
  12. type TcpServer(poolSize, perOperationBufferSize, acceptBacklogCount, received, ?connected, ?disconnected, ?sent) as s=
  13. let connected = defaultArg connected (fun ep -> Debug.WriteLine(sprintf "%A %A: Connected" DateTime.UtcNow.TimeOfDay ep))
  14. let disconnected = defaultArg disconnected (fun ep -> Debug.WriteLine(sprintf "%A %A: Disconnected" DateTime.UtcNow.TimeOfDay ep))
  15. let sent = defaultArg sent (fun (received:byte[], ep) -> Debug.WriteLine( sprintf "%A Sent: %A " DateTime.UtcNow.TimeOfDay received.Length ))
  16. let pool = new BocketPool("regular pool", max poolSize 2, perOperationBufferSize)
  17. let connectionPool = new BocketPool("connection pool", max acceptBacklogCount 2, 288)(*288 bytes is the minimum size for a connection*)
  18. let clients = new ConcurrentDictionary<_,_>()
  19. let connections = ref 0
  20. let listeningSocket = new Socket(AddressFamily.InterNetwork, SocketType.Stream, ProtocolType.Tcp)
  21. let mutable disposed = false
  22. //ensures the listening socket is shutdown on disposal.
  23. let cleanUp(socket) =
  24. if not disposed && socket <> null then
  25. disposed <- true
  26. disposeSocket socket
  27. (pool :> IDisposable).Dispose()
  28. let disconnect (sd:SocketDescriptor) =
  29. !-- connections
  30. disconnected sd.RemoteEndPoint
  31. sd.Socket.Close()
  32. ///This function is called on each connect,sends,receive, and disconnect
  33. let rec completed (args:SocketAsyncEventArgs) =
  34. try
  35. match args.LastOperation with
  36. | SocketAsyncOperation.Accept -> processAccept(args)
  37. | SocketAsyncOperation.Receive -> processReceive(args)
  38. | SocketAsyncOperation.Send -> processSend(args)
  39. | SocketAsyncOperation.Disconnect -> processDisconnect(args)
  40. | _ -> args.LastOperation |> failwith "Unknown operation: %a"
  41. finally
  42. args.UserToken <- null
  43. pool.CheckIn(args)
  44. and processAccept (args) =
  45. let acceptSocket = args.AcceptSocket
  46. match args.SocketError with
  47. | SocketError.Success ->
  48. //start next accept
  49. let saea = pool.CheckOut()
  50. do listeningSocket.AcceptAsyncSafe(completed, saea)
  51. //process newly connected client
  52. let endPoint = acceptSocket.RemoteEndPoint :?> IPEndPoint
  53. clients.AddOrUpdate(endPoint, acceptSocket, fun a b -> (acceptSocket)) |> ignore
  54. //if not success then failwith "client could not be added"
  55. //trigger connected
  56. connected endPoint
  57. !++ connections
  58. args.AcceptSocket <- null (*remove the AcceptSocket because we're reusing args*)
  59. let sd = {Socket = acceptSocket; RemoteEndPoint = endPoint}
  60. //start receive on accepted client
  61. let receiveSaea = pool.CheckOut()
  62. receiveSaea.UserToken <- sd
  63. acceptSocket.ReceiveAsyncSafe(completed, receiveSaea)
  64. //check if data was given on connection
  65. if args.BytesTransferred > 0 then
  66. let data = acquireData args
  67. //trigger received
  68. received (data, s, sd)
  69. | SocketError.OperationAborted
  70. | SocketError.Disconnecting when disposed -> ()// stop accepting here, we're being shutdown.
  71. | _ -> Debug.WriteLine (sprintf "socket error on accept: %A" args.SocketError)
  72. and processDisconnect (args) =
  73. let sd = args.UserToken :?> SocketDescriptor
  74. sd |> disconnect
  75. and processReceive (args) =
  76. let sd = args.UserToken :?> SocketDescriptor
  77. let socket = sd.Socket
  78. if args.SocketError = SocketError.Success && args.BytesTransferred > 0 then
  79. //process received data, check if data was given on connection.
  80. let data = acquireData args
  81. //trigger received
  82. received (data, s, sd )
  83. //get on with the next receive
  84. if socket.Connected then
  85. let saea = pool.CheckOut()
  86. saea.UserToken <- sd
  87. socket.ReceiveAsyncSafe( completed, saea)
  88. else ()
  89. //0 byte receive - disconnect.
  90. else disconnect sd
  91. and processSend (args) =
  92. let sd = args.UserToken :?> SocketDescriptor
  93. match args.SocketError with
  94. | SocketError.Success ->
  95. let sentData = acquireData args
  96. //notify data sent
  97. sent (sentData, sd.RemoteEndPoint)
  98. | SocketError.NoBufferSpaceAvailable
  99. | SocketError.IOPending
  100. | SocketError.WouldBlock ->
  101. failwith "Buffer overflow or send buffer timeout" //graceful termination?
  102. | _ -> args.SocketError.ToString() |> printfn "socket error on send: %s"
  103. static member Create(received, ?connected, ?disconnected, ?sent) =
  104. new TcpServer(5000, 1024, 2000, received, ?connected = connected, ?disconnected = disconnected, ?sent = sent)
  105. member s.Connections = connections
  106. ///Starts the accepting a incoming connections.
  107. member s.Listen(?address, ?port) =
  108. let address = defaultArg address IPAddress.Loopback
  109. let port = defaultArg port 80
  110. //initialise the pool
  111. pool.Start(completed)
  112. ///starts listening on the specified address and port.
  113. listeningSocket.Bind(IPEndPoint(address, port))
  114. listeningSocket.Listen(acceptBacklogCount)
  115. for i in 1 .. 4 do
  116. listeningSocket.AcceptAsyncSafe(completed, pool.CheckOut())
  117. ///Sends the specified message to the client.
  118. member s.Send(clientEndPoint, msg, ?close) =
  119. let success, client = clients.TryGetValue(clientEndPoint)
  120. let close = defaultArg close true
  121. if success then
  122. send {Socket = client;RemoteEndPoint = clientEndPoint} completed pool.CheckOut perOperationBufferSize msg close
  123. else failwith "could not find client %"
  124. interface IDisposable with
  125. member s.Dispose() = cleanUp listeningSocket