From a55337a347aedf61333a679b39774fc03c298510 Mon Sep 17 00:00:00 2001 From: Isaac Shapira Date: Thu, 21 Jan 2016 23:34:24 -0700 Subject: [PATCH 1/2] fixed conflicts (LOL merge -s ours; push -f) --- elm-package.json | 77 +++++++++++++++++++----------------- src/Http/Server.elm | 5 +-- src/Http/Server/Request.elm | 11 +++++- src/Http/Server/Response.elm | 11 +++++- src/Native/Network.js | 8 +++- src/Native/Network.wisp | 6 +++ 6 files changed, 75 insertions(+), 43 deletions(-) diff --git a/elm-package.json b/elm-package.json index f10bf77..6d5e2d0 100644 --- a/elm-package.json +++ b/elm-package.json @@ -8,48 +8,51 @@ "examples/LowLevel/isomorphic-templating" ], "exposed-modules": [ - "Network", - "Network.Socket", - "Streams.Types", - "Streams.String", - "Streams.Buffer", - "Streams.Chunk", - "Streams", - "Process", - "Process.Types", - "Process.User", - "Process.Streams", - "FileSystem.Streams.Read", - "FileSystem.Streams.Write", - "FileSystem.Types", - "FileSystem.Write.String", - "FileSystem.Write.String.Descriptor", - "FileSystem.Write.Buffer", - "FileSystem.Write.Buffer.Descriptor", - "FileSystem.Write.Chunk", - "FileSystem.Descriptor", - "FileSystem.Watch", - "FileSystem.Read", - "FileSystem", - "DomainNameService", - "Chunk", - "Chunk.Types", - "Console", - "Console.Color", - "Compression", - "Compression.Types", - "Http.Types", - "Http.StatusCode", - "Http.Agent", - "Http.Agent.TLS", - "Http.Server", - "Http.Server.TLS", - "Http.Server.Response" + "Network", + "Network.Socket", + "Streams.Types", + "Streams.String", + "Streams.Buffer", + "Streams.Chunk", + "Streams", + "Process", + "Process.Types", + "Process.User", + "Process.Streams", + "FileSystem.Streams.Read", + "FileSystem.Streams.Write", + "FileSystem.Types", + "FileSystem.Write.String", + "FileSystem.Write.String.Descriptor", + "FileSystem.Write.Buffer", + "FileSystem.Write.Buffer.Descriptor", + "FileSystem.Write.Chunk", + "FileSystem.Descriptor", + "FileSystem.Watch", + "FileSystem.Read", + "FileSystem", + "DomainNameService", + "Chunk", + "Chunk.Types", + "Console", + "Console.Color", + "Compression", + "Compression.Types", + "Http.Types", + "Http.StatusCode", + "Http.Agent", + "Http.Agent.TLS", + "Http.Server", + "Http.Server.TLS", + "Http.Server.Response", + "Http.Server.Request", + "Http.Client.Request" ], "native-modules": true, "dependencies": { "JustusAdam/elm-path": "1.3.0 <= v < 2.0.0", "elm-lang/core": "3.0.0 <= v < 4.0.0", + "evancz/elm-effects": "2.0.1 <= v < 3.0.0", "evancz/elm-html": "4.0.2 <= v < 5.0.0", "evancz/elm-http": "3.0.0 <= v < 4.0.0", "evancz/virtual-dom": "2.1.0 <= v < 3.0.0", diff --git a/src/Http/Server.elm b/src/Http/Server.elm index ff6e276..77bc7cc 100644 --- a/src/Http/Server.elm +++ b/src/Http/Server.elm @@ -24,7 +24,6 @@ import Foreign.Marshall as Marshall import Foreign.Pattern.Method as Method import Foreign.Pattern.Get as Get import Foreign.Pattern.Member as Member -import Foreign.Pattern.Member as Member import Http.Types exposing (..) import Http.Marshall exposing (..) import Network.Types as Net @@ -102,9 +101,9 @@ Emitted each time there is a request. Note that there may be multiple requests p keep-alive connections). request is an instance of http.IncomingMessage and response is an instance of http.ServerResponse. -} -onRequest : Server -> (( RequestRaw, Response ) -> Task x ()) -> Task x (Task x ()) +onRequest : Server -> (( Request, Response ) -> Task x ()) -> Task x (Task x ()) onRequest server f = - Emitter.on2 "request" server (\( req, res ) -> f ( req, marshallResponse res )) + Emitter.on2 "request" server (\( req, res ) -> f ( marshallRequest req, marshallResponse res )) {-| diff --git a/src/Http/Server/Request.elm b/src/Http/Server/Request.elm index 40aa7d8..3f08b98 100644 --- a/src/Http/Server/Request.elm +++ b/src/Http/Server/Request.elm @@ -1,7 +1,7 @@ module Http.Server.Request (..) where {-| -Class: http.IncomingMessage# +Class: http.IncomingMessage An IncomingMessage object is created by http.Server or http.ClientRequest and passed as the first argument to the 'request' and 'response' event respectively. It may be used to access response status, headers and data. It implements the Readable Stream interface, as well as the following additional events, methods, and properties. @@ -15,6 +15,7 @@ import Emitter.Unsafe as Emitter import Network.Types exposing (..) import Task exposing (Task) import Time exposing (Time) +import Native.Network infixr 4 `map` @@ -23,6 +24,14 @@ map = Task.map +{-| +none, request +-} +emptyRequest : Request +emptyRequest = + Native.Network.emptyReq + + {-| Event: 'close' Indicates that the underlying connection was closed. diff --git a/src/Http/Server/Response.elm b/src/Http/Server/Response.elm index 0517176..76a415c 100644 --- a/src/Http/Server/Response.elm +++ b/src/Http/Server/Response.elm @@ -6,7 +6,7 @@ module Http.Server.Response (..) where @docs onClose, onFinish # Response -@docs end +@docs end, emptyResponse # Write @docs write, writeBuffer, writeChunk, writeHead, writeContinue @@ -32,6 +32,15 @@ import Task exposing (Task) import Time exposing (Time) import Json.Encode as Encode import Http.StatusCode exposing (StatusCode) +import Native.Network + + +{-| +NoOp response +-} +emptyResponse : Response +emptyResponse = + Native.Network.emptyRes {-| diff --git a/src/Native/Network.js b/src/Native/Network.js index dcc293d..8974f73 100644 --- a/src/Native/Network.js +++ b/src/Native/Network.js @@ -4,7 +4,13 @@ var make = function make(localRuntime) { return localRuntime.Native.Network.values ? localRuntime.Native.Network.values : localRuntime.Native.Network.values = { 'marshallSocketAddress': F4(function (IPv4, IPv6, SocketAddress, raw) { return A3(SocketAddress(raw.port, 'IPv6' == raw.family ? IPv4 : IPv6, raw.address)); - }) + }), + 'emptyReq': {}, + 'emptyRes': { + 'end': noop, + 'write': noop, + 'writeHead': noop + } }; })(); }; diff --git a/src/Native/Network.wisp b/src/Native/Network.wisp index 4c34321..0b2cef3 100644 --- a/src/Native/Network.wisp +++ b/src/Native/Network.wisp @@ -14,6 +14,12 @@ IPv6) raw.address)))) + :emptyReq {} + :emptyRes { + :end noop + :write noop + :writeHead noop} + } )))) (foreign.sanitize Elm :Native :Network) From 31f3112e663650e97888087e078d070730f460c7 Mon Sep 17 00:00:00 2001 From: Isaac Shapira Date: Sat, 23 Jan 2016 14:36:40 -0700 Subject: [PATCH 2/2] fubar --- examples/HighLevel/AppServer/Main.elm | 95 +++++++++++++++++++-------- examples/HighLevel/AppServer/run.sh | 3 + src/Http/Server/Response.elm | 8 ++- src/Native/Network.wisp | 2 +- src/Server/StartApp.elm | 69 ++----------------- 5 files changed, 84 insertions(+), 93 deletions(-) create mode 100644 examples/HighLevel/AppServer/run.sh diff --git a/examples/HighLevel/AppServer/Main.elm b/examples/HighLevel/AppServer/Main.elm index e72546c..cfcf475 100644 --- a/examples/HighLevel/AppServer/Main.elm +++ b/examples/HighLevel/AppServer/Main.elm @@ -1,51 +1,94 @@ module Main (..) where import Effects exposing (..) -import Task exposing (Task) -import Server.StartApp exposing (..) +import Task exposing (Task, andThen) +import Http.Types exposing (..) +import Http.Server.Request exposing (emptyRequest) +import Http.Server.Response exposing (emptyResponse, end) +import Http.Server exposing (createServer, onRequest, listen) +import Http.StatusCode exposing (StatusCode) +import Streams.String exposing (write) +import Foreign.Pattern.Member as Member +import Foreign.Marshall as Marshall import Signal exposing (..) -import Server exposing (..) +import Console -type Action - = Incoming Request - | Created Server +(=>) : Task x a -> Task x b -> Task x b +(=>) t t' = + t `andThen` always t' -type alias Model = - Int +type alias RequestRaw = + Http.Types.Request + + +type alias ResponseRaw = + Http.Types.Response -update : Action -> Model -> ( Model, Effects Action ) -update _ _ = - ( 0, none ) +type ServerAction action + = Incoming RequestRaw + | Outgoing ResponseRaw + | Cycle action -config : Config Model Action -config = - { init = ( 0, none ) - , update = update - , inputs = [] +type alias Request = + { url : String + , method : Http.Types.METHOD + , statusCode : StatusCode } -app : App Model -app = - start config +marshallRequest : RequestRaw -> Request +marshallRequest { request } = + let + read = flip Member.unsafeRead request + + marshallStatusCode = + Http.StatusCode.fromInt + >> Marshall.unsafeNothingIsUndefined + + marshallMETHOD = + readMethod + >> Marshall.unsafeNothingIsUndefined + in + Request + (read "url") + (read "method" |> marshallMETHOD) + (read "statusCode" |> marshallStatusCode) + + +type Response + = Html String + | Json String + | Text String + + +type alias Model = + Int + + +connection : Mailbox ( RequestRaw, ResponseRaw ) +connection = + mailbox ( emptyRequest, emptyResponse ) -server : Mailbox ( Request, Response ) -server = - mailbox ( emptyReq, emptyRes ) +respond : String -> ResponseRaw -> Task Never () +respond message res = + write (Debug.log "res" res) message => end res -port tasks : Signal (Task Never ()) -port tasks = - app.tasks +port response : Signal (Task Never ()) +port response = + Signal.map (\( _, res ) -> respond "hello" res) connection.signal port serve : Task Never () port serve = createServer `andThen` \server -> -flip flionRequest server () + Console.blue "listening on 8000" + => listen server 8000 + => onRequest server (send connection.address) + => Task.succeed () diff --git a/examples/HighLevel/AppServer/run.sh b/examples/HighLevel/AppServer/run.sh new file mode 100644 index 0000000..faf4c06 --- /dev/null +++ b/examples/HighLevel/AppServer/run.sh @@ -0,0 +1,3 @@ +elm make examples/HighLevel/AppServer/Main.elm --output=examples/HighLevel/AppServer/main.js +echo "Elm.worker(Elm.Main);" >> examples/HighLevel/AppServer/main.js +node examples/HighLevel/AppServer/main.js diff --git a/src/Http/Server/Response.elm b/src/Http/Server/Response.elm index d414362..64a1850 100644 --- a/src/Http/Server/Response.elm +++ b/src/Http/Server/Response.elm @@ -21,6 +21,7 @@ module Http.Server.Response (..) where import Foreign.Pattern.Method as Method import Foreign.Pattern.Member as Member +import Foreign.Marshall as Marshall import Streams.Chunk import Streams.String import Streams.Buffer @@ -40,7 +41,12 @@ NoOp response -} emptyResponse : Response emptyResponse = - Native.Network.emptyRes + let + raw = Native.Network.emptyRes + in + { writable = Marshall.unsafeIdentity raw + , response = Marshall.unsafeIdentity raw + } {-| diff --git a/src/Native/Network.wisp b/src/Native/Network.wisp index 1a56449..a573e60 100644 --- a/src/Native/Network.wisp +++ b/src/Native/Network.wisp @@ -18,7 +18,7 @@ :emptyRes { :end (fn [] nil) :write (fn [] nil) - :writeHead (fn [] nil)} + :writeHead (fn [] nil) } } )))) diff --git a/src/Server/StartApp.elm b/src/Server/StartApp.elm index eebd022..2f8a0cd 100644 --- a/src/Server/StartApp.elm +++ b/src/Server/StartApp.elm @@ -3,7 +3,10 @@ module Server.StartApp (..) where import Effects exposing (Effects, Never) import Signal exposing (Signal, Mailbox, mailbox) import Task exposing (Task, andThen) -import Streams.String exposing (write) + + +-- import Streams.String exposing (write) + import Server exposing (..) @@ -84,67 +87,3 @@ start config = { model = model , tasks = Signal.map (Effects.toTask messages.address << snd) effectsAndModel } - - -respond : String -> Response -> Effects (Action action) -respond message response = - write response message - => Task.succeed (Outgoing response) - |> Effects.task - - -cycle : action -> Effects (Action action) -cycle = - Effects.task << Task.succeed << Cycle - - -startServer : ServerConfig model action -> App model -startServer config = - let - singleton action = [ action ] - - -- messages : Signal.Mailbox (List action) - messages = - Signal.mailbox [] - - -- address : Signal.Address action - address = - Signal.forwardTo messages.address singleton - - -- connection : Signal.Mailbox (Request, Response) - connection = - Signal.mailbox ( emptyRequest, emptyResponse ) - - -- server : Task x () - server = - serve config.port' connection.address - |> Task.map (always ()) - - -- updateStep : action -> (model, Effects action) -> (model, Effects action) - updateStep action ( oldModel, accumulatedEffects ) = - let - ( newModel, additionalEffects ) = config.update action oldModel - in - ( newModel, Effects.batch [ accumulatedEffects, additionalEffects ] ) - - -- update : List action -> (model, Effects action) -> (model, Effects action) - update actions ( model, _ ) = - List.foldl updateStep ( model, Effects.none ) actions - - -- inputs : Signal (List action) - inputs = - Signal.mergeMany (messages.signal :: List.map (Signal.map singleton) config.inputs) - - -- effectsAndModel : Signal (model, Effects action) - effectsAndModel = - Signal.foldp update config.init - <| Signal.merge (Signal.map (List.map Cycle) inputs) <| Signal.map (List.map ...) - - model = - Signal.map fst effectsAndModel - in - { model = model - , tasks = - Signal.map (Effects.toTask messages.address << snd) effectsAndModel - |> Signal.merge (Signal.constant server) - }