diff --git a/Saturn.sln b/Saturn.sln index dc8dc2fc..3e650237 100644 --- a/Saturn.sln +++ b/Saturn.sln @@ -45,6 +45,8 @@ Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "AzureADAuthSample", "sample EndProject Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "WorkerSample", "sample\WorkerSample\WorkerSample.fsproj", "{34881EBD-FAB7-45A5-8166-45B9CC85A0E0}" EndProject +Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "Saturn.LiveView", "src\Saturn.LiveView\Saturn.LiveView.fsproj", "{1F68DB09-7A15-4D86-822D-5D9F62FE1372}" +EndProject Project("{2150E333-8FDC-42A3-9474-1A3956D46DE8}") = "benchmark", "benchmark", "{CA96E36B-6981-4056-AAE8-1D6FA3CD07E4}" EndProject Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "GiraffeBench", "benchmark\GiraffeBench\GiraffeBench.fsproj", "{FC8B2AB6-79A4-48CC-9B83-AF84DEF17BA7}" @@ -304,6 +306,18 @@ Global {2885CF04-BCEE-457B-B013-36FE935030BF}.Release|x64.Build.0 = Release|Any CPU {2885CF04-BCEE-457B-B013-36FE935030BF}.Release|x86.ActiveCfg = Release|Any CPU {2885CF04-BCEE-457B-B013-36FE935030BF}.Release|x86.Build.0 = Release|Any CPU + {1F68DB09-7A15-4D86-822D-5D9F62FE1372}.Debug|Any CPU.ActiveCfg = Debug|Any CPU + {1F68DB09-7A15-4D86-822D-5D9F62FE1372}.Debug|Any CPU.Build.0 = Debug|Any CPU + {1F68DB09-7A15-4D86-822D-5D9F62FE1372}.Debug|x64.ActiveCfg = Debug|Any CPU + {1F68DB09-7A15-4D86-822D-5D9F62FE1372}.Debug|x64.Build.0 = Debug|Any CPU + {1F68DB09-7A15-4D86-822D-5D9F62FE1372}.Debug|x86.ActiveCfg = Debug|Any CPU + {1F68DB09-7A15-4D86-822D-5D9F62FE1372}.Debug|x86.Build.0 = Debug|Any CPU + {1F68DB09-7A15-4D86-822D-5D9F62FE1372}.Release|Any CPU.ActiveCfg = Release|Any CPU + {1F68DB09-7A15-4D86-822D-5D9F62FE1372}.Release|Any CPU.Build.0 = Release|Any CPU + {1F68DB09-7A15-4D86-822D-5D9F62FE1372}.Release|x64.ActiveCfg = Release|Any CPU + {1F68DB09-7A15-4D86-822D-5D9F62FE1372}.Release|x64.Build.0 = Release|Any CPU + {1F68DB09-7A15-4D86-822D-5D9F62FE1372}.Release|x86.ActiveCfg = Release|Any CPU + {1F68DB09-7A15-4D86-822D-5D9F62FE1372}.Release|x86.Build.0 = Release|Any CPU EndGlobalSection GlobalSection(NestedProjects) = preSolution {8DBA089A-7C24-4E87-870B-E0774654F376} = {F2C8C347-845F-42E4-A702-7381C4B4087F} @@ -326,5 +340,6 @@ Global {34881EBD-FAB7-45A5-8166-45B9CC85A0E0} = {511FB392-5714-4028-97F3-F883F81B43DB} {FC8B2AB6-79A4-48CC-9B83-AF84DEF17BA7} = {CA96E36B-6981-4056-AAE8-1D6FA3CD07E4} {2885CF04-BCEE-457B-B013-36FE935030BF} = {CA96E36B-6981-4056-AAE8-1D6FA3CD07E4} + {1F68DB09-7A15-4D86-822D-5D9F62FE1372} = {F2C8C347-845F-42E4-A702-7381C4B4087F} EndGlobalSection EndGlobal diff --git a/paket.dependencies b/paket.dependencies index 9d93552c..07a78bf1 100644 --- a/paket.dependencies +++ b/paket.dependencies @@ -19,6 +19,7 @@ nuget protobuf-net.Grpc.AspNetCore nuget protobuf-net.Grpc.HttpClient nuget FSharp.Control.Websockets >= 0.2 nuget FSharp.Core >= 4.2.3 +nuget Elmish group Docs source https://api.nuget.org/v3/index.json diff --git a/paket.lock b/paket.lock index 362f3cc6..73470c9b 100644 --- a/paket.lock +++ b/paket.lock @@ -31,6 +31,8 @@ NUGET System.Reflection.TypeExtensions (>= 4.3) System.Xml.XmlDocument (>= 4.3) CommandLineParser (2.8) + Elmish (3.0.6) + FSharp.Core (>= 4.6.2) Expecto (9.0) FSharp.Core (>= 4.6) Mono.Cecil (>= 0.11.2) diff --git a/src/Saturn.LiveView/LiveView.fs b/src/Saturn.LiveView/LiveView.fs new file mode 100644 index 00000000..707272e3 --- /dev/null +++ b/src/Saturn.LiveView/LiveView.fs @@ -0,0 +1,192 @@ +namespace Saturn + +open Channels +open Microsoft.AspNetCore.Http +open Microsoft.Extensions.DependencyInjection +open System.Threading.Tasks +open Giraffe.GiraffeViewEngine +open Elmish +open FSharp.Control.Tasks.V2 + +module LiveComponenet = + type ILiveComponenet = + abstract member InternalChannel : IChannel with get + + type LiveComponentMsg = {Event: string; ElementId: string; Data: string} + type internal ViewUpdateMsg = {ComponentId: string; Data: string} + +[] +module LiveComponentBuilder = + open LiveComponenet + + type LiveComponenetBuilderState<'State, 'Msg> = { + Join: (HttpContext -> ClientInfo -> Task) option + Init: (HttpContext -> ClientInfo -> (Cmd<'Msg> -> unit) -> Task<'State * Cmd<'Msg>>) option + Update: (HttpContext -> ClientInfo -> 'Msg -> 'State -> Task<'State * Cmd<'Msg>>) option + View: (HttpContext -> ClientInfo -> 'State -> XmlNode) option + MessageMap: (HttpContext -> ClientInfo -> LiveComponentMsg -> 'Msg) option + } + + type internal StateMsg<'State, 'Msg> = + | Init of HttpContext * ClientInfo + | SetState of 'State + | Dispatch of Cmd<'Msg> + | Update of 'Msg + + + type LiveComponenetBuilder<'State, 'Msg> internal (componentId: string) = + + member __.Yield (_) : LiveComponenetBuilderState<'State, 'Msg> = + {Join = None; Init = None; Update = None; View = None; MessageMap = None} + + [] + ///Action executed when client tries to join the channel. + ///You can either return `Ok` if channel allows join, or reject it with `Rejected` + ///Typical cases for rejection may include authorization/authentication, + ///not being able to handle more connections or other business logic reasons. + /// + /// As arguments, `join` action gets: + /// * current `HttpContext` for the request + /// * `ClientInfo` instance representing additional information about client sending request + member __.Join (state, handler) : LiveComponenetBuilderState<'State, 'Msg> = + {state with Join = handler} + + [] + ///Action executed after client succesfully join the channel. Used to set initial state of the compnent. + /// + /// As arguments, `init` action gets: + /// * current `HttpContext` for the request + /// * `ClientInfo` instance representing additional information about client sending request + /// * `(Cmd<'Msg> -> unit)` function that can be used to dispatch additional messages (for example used when in `init` you can subscribe to external events) + /// + /// Returns: `Task<'State * Cmd<'Msg>>` + member __.Init (state, handler) : LiveComponenetBuilderState<'State, 'Msg> = + {state with Init = handler} + + [] + ///Action executed after client performs some event in the component + /// + /// As arguments, `update` action gets: + /// * current `HttpContext` for the request + /// * `ClientInfo` instance representing additional information about client sending request + /// * message `'Msg` that represetns event that happened + /// + /// Returns: `Task<'State * Cmd<'Msg>>` + member __.Update (state, handler) : LiveComponenetBuilderState<'State, 'Msg> = + {state with Update = handler} + + [] + ///Function responsible for mapping current state to the view + /// + /// As arguments, `view` action gets: + /// * current `HttpContext` for the request + /// * `ClientInfo` instance representing additional information about client sending request + /// * current state `'State` + /// + /// Returns: `XmlNode` (Giraffe.ViewEngine) + member __.View (state, handler) : LiveComponenetBuilderState<'State, 'Msg> = + {state with View = handler} + + [] + ///Function responsible for mapping raw messages into component domain messages + /// + /// As arguments, `message_map` action gets: + /// * current `HttpContext` for the request + /// * `ClientInfo` instance representing additional information about client sending request + /// * instance of `LiveComponentMsg` representing raw message + /// + /// Returns: `'Msg` representing domain message + member __.MessageMap (state, handler) : LiveComponenetBuilderState<'State, 'Msg> = + {state with MessageMap = handler} + + member __.Run (state : LiveComponenetBuilderState<'State, 'Msg>) : ILiveComponenet = + if state.Join.IsNone then failwith "Join is required operation for any Live Component. Please use `join` operation in your `liveComponent` CE to define it." + if state.Init.IsNone then failwith "Init is required operation for any Live Component. Please use `init` operation in your `liveComponent` CE to define it." + if state.View.IsNone then failwith "View is required operation for any Live Component. Please use `view` operation in your `liveComponent` CE to define it." + if state.Update.IsNone then failwith "Update is required operation for any Live Component. Please use `update` operation in your `liveComponent` CE to define it." + if state.MessageMap.IsNone then failwith "MessageMap is required operation for any Live Component. Please use `message_map` operation in your `liveComponent` CE to define it." + + + let joinH = state.Join.Value + let initH = state.Init.Value + let viewH = state.View.Value + let updateH = state.Update.Value + let mmH = state.MessageMap.Value + + let c = + let rec stateMP = MailboxProcessor.Start(fun inbox -> + + let rec messageLoop(state: 'State, (ctx: HttpContext), ci) = async { + let! msg = inbox.Receive() + let! newState, ctx, ci = + match msg with + | Init (ctx, ci) -> + async { return state, ctx, ci} + | SetState (state) -> + async { + let clientHub = ctx.RequestServices.GetService () + let viewTemplate = viewH ctx ci state + let viewStr = Giraffe.GiraffeViewEngine.renderHtmlDocument viewTemplate + let viewMsg = {ComponentId = componentId; Data = viewStr} + do! clientHub.SendMessageToClient ci "liveComponent" viewMsg |> Async.AwaitTask + + return state, ctx, ci + } + | Update msg -> + async { + let! (state, cmd) = (updateH ctx ci msg state |> Async.AwaitTask) + + let clientHub = ctx.RequestServices.GetService () + let viewTemplate = viewH ctx ci state + let viewStr = Giraffe.GiraffeViewEngine.renderHtmlDocument viewTemplate + let viewMsg = {ComponentId = componentId; Data = viewStr} + do! clientHub.SendMessageToClient ci "liveComponent" viewMsg |> Async.AwaitTask + + inbox.Post (Dispatch cmd) + return state, ctx, ci + } + | Dispatch (cmd: Cmd<'Msg>) -> + async { + cmd |> List.iter (fun n -> n (Update >> inbox.Post) ) + return state, ctx, ci + } + return! messageLoop (newState, ctx, ci) } + + let inState = Unchecked.defaultof<'State> + let inCtx = Unchecked.defaultof + let inCi = Unchecked.defaultof + messageLoop (inState, inCtx, inCi) + ) + + channel { + join (fun ctx si -> task { + let! res = joinH ctx si + match res with + | JoinResult.Ok -> + stateMP.Post (Init (ctx, si)) + let! (s,cmd) = initH ctx si (Dispatch >> stateMP.Post) + stateMP.Post (SetState s) + stateMP.Post (Dispatch cmd) + | _ -> + () + return res + }) + + handle "liveComponent" (fun ctx si (msg: Message) -> task { + let m = mmH ctx si msg.Payload + stateMP.Post (Update m) + return () + }) + + terminate (fun ctx si -> task { + (stateMP :> System.IDisposable).Dispose() + return () + }) + } + + { new ILiveComponenet with + member __.InternalChannel with get () = c + } + + let liveComponent<'State, 'Msg> id = LiveComponenetBuilder<'State, 'Msg>(id) + diff --git a/src/Saturn.LiveView/Saturn.LiveView.fsproj b/src/Saturn.LiveView/Saturn.LiveView.fsproj new file mode 100644 index 00000000..cf833459 --- /dev/null +++ b/src/Saturn.LiveView/Saturn.LiveView.fsproj @@ -0,0 +1,23 @@ + + + Library + netcoreapp3.1 + portable + true + Saturn LiveView - rich, real-time user experience with server-rendered HTML. + + + + Saturn.fsproj + + + + + + + + + + + + diff --git a/src/Saturn.LiveView/paket.references b/src/Saturn.LiveView/paket.references new file mode 100644 index 00000000..0e9b962b --- /dev/null +++ b/src/Saturn.LiveView/paket.references @@ -0,0 +1,2 @@ +Elmish +FSharp.Core diff --git a/src/Saturn/Channels.fs b/src/Saturn/Channels.fs index ad2c5879..c2fa45ab 100644 --- a/src/Saturn/Channels.fs +++ b/src/Saturn/Channels.fs @@ -8,7 +8,6 @@ open Microsoft.Extensions.DependencyInjection open Microsoft.Extensions.Logging open System open System.Collections.Concurrent -open System.Collections.Generic open System.Net.WebSockets open System.Threading open System.Threading.Tasks @@ -32,10 +31,10 @@ module Channels = ///Type representing information about client that has executed some channel action ///It's passed as an argument in channel actions (`join`, `handle`, `terminate`) - type ClientInfo = { SocketId: SocketId } + type ClientInfo = { SocketId: SocketId; ChannelPath: ChannelPath } with - static member New socketId = - { SocketId = socketId } + static member New channelPath socketId = + { SocketId = socketId; ChannelPath = channelPath } ///Type representing result of `join` action. It can be either succesful (`Ok`) or you can reject client connection (`Rejected`) type JoinResult = @@ -53,11 +52,12 @@ module Channels = /// You can get instance of it with `ctx.GetService<Saturn.Channels.ISocketHub>()` from any place that has access to HttpContext instance (`controller` actions, `channel` actions, normal `HttpHandler`) type ISocketHub = abstract member SendMessageToClients: ChannelPath -> Topic -> 'a -> Task - abstract member SendMessageToClient: ChannelPath -> SocketId -> Topic -> 'a -> Task + abstract member SendMessageToClient: ClientInfo -> Topic -> 'a -> Task + abstract member SendMessageToClientsFilter: (ClientInfo -> bool) -> Topic -> 'a -> Task /// A type that wraps access to connected websockets by endpoint type SocketHub(serializer: IJsonSerializer) = - let sockets = Dictionary>() + let sockets = ConcurrentDictionary() let sendMessage (msg: 'a Message) (socket: Socket.ThreadSafeWebSocket) = task { let text = serializer.SerializeToString msg @@ -67,28 +67,40 @@ module Channels = | Error exn -> return exn.Throw() } - member __.NewPath path = - match sockets.TryGetValue path with - | true, _path -> () - | false, _ -> sockets.[path] <- ConcurrentDictionary() + member __.ConnectSocketToPath path clientId socket = + let ci = {SocketId = clientId; ChannelPath = path} + sockets.AddOrUpdate(ci, socket, fun _ _ -> socket) |> ignore + ci - member __.ConnectSocketToPath path id socket = - sockets.[path].AddOrUpdate(id, socket, fun _ _ -> socket) |> ignore - id - - member __.DisconnectSocketForPath path socketId = - sockets.[path].TryRemove socketId |> ignore + member __.DisconnectSocketForPath path clientId = + let ci = {SocketId = clientId; ChannelPath = path} + sockets.TryRemove ci |> ignore interface ISocketHub with + member __.SendMessageToClientsFilter(predicate: ClientInfo -> bool) (topic: Topic) (payload: 'a): Task = task { + let msg = { Topic = topic; Ref = ""; Payload = payload } + let tasks = + sockets + |> Seq.filter (fun n -> predicate n.Key) + |> Seq.map (fun n -> sendMessage msg n.Value) + + let! _results = Task.WhenAll tasks + return () + } + member __.SendMessageToClients path topic payload = task { let msg = { Topic = topic; Ref = ""; Payload = payload } - let tasks = [for kvp in sockets.[path] -> sendMessage msg kvp.Value ] + let tasks = + sockets + |> Seq.filter (fun n -> n.Key.ChannelPath = path) + |> Seq.map (fun n -> sendMessage msg n.Value) + let! _results = Task.WhenAll tasks return () } - member __.SendMessageToClient path clientId topic payload = task { - match sockets.[path].TryGetValue clientId with + member __.SendMessageToClient clientInfo topic payload = task { + match sockets.TryGetValue clientInfo with | true, socket -> let msg = { Topic = topic; Ref = ""; Payload = payload } do! sendMessage msg socket @@ -96,8 +108,6 @@ module Channels = } type SocketMiddleware(next : RequestDelegate, serializer: IJsonSerializer, path: string, channel: IChannel, sockets: SocketHub, logger: ILogger) = - do sockets.NewPath path - member __.Invoke(ctx : HttpContext) = task { if ctx.Request.Path = PathString(path) then @@ -106,14 +116,14 @@ module Channels = let logger = ctx.RequestServices.GetRequiredService>() logger.LogTrace("Promoted websocket request") let socketId = Guid.NewGuid() - let socketInfo = ClientInfo.New socketId - let! joinResult = channel.Join(ctx, socketInfo) + let clientInfo = ClientInfo.New path socketId + let! joinResult = channel.Join(ctx, clientInfo) match joinResult with | Ok -> logger.LogTrace("Joined channel {path}", path) let! webSocket = ctx.WebSockets.AcceptWebSocketAsync() let wrappedSocket = Socket.createFromWebSocket webSocket - let socketId = sockets.ConnectSocketToPath path socketId wrappedSocket + let clientInfo = sockets.ConnectSocketToPath path socketId wrappedSocket while wrappedSocket.State = WebSocketState.Open do match! Socket.receiveMessageAsUTF8 wrappedSocket with @@ -122,7 +132,7 @@ module Channels = | Result.Ok (WebSocket.ReceiveUTF8Result.String msg) -> logger.LogTrace("received message {0}", msg) try - do! channel.HandleMessage(ctx, socketInfo, serializer, msg) + do! channel.HandleMessage(ctx, clientInfo, serializer, msg) with | ex -> // typically a deserialization error, swallow @@ -132,8 +142,8 @@ module Channels = logger.LogError(exn.SourceException, "Error while receiving message") () // TODO: ? - do! channel.Terminate (ctx, socketInfo) - sockets.DisconnectSocketForPath path socketId + do! channel.Terminate (ctx, clientInfo) + sockets.DisconnectSocketForPath path clientInfo.SocketId let! result = Socket.close wrappedSocket WebSocketCloseStatus.NormalClosure "Closing channel" match result with | Result.Ok () ->