diff --git a/elm-package.json b/elm-package.json index 4368e92..0113327 100644 --- a/elm-package.json +++ b/elm-package.json @@ -44,7 +44,8 @@ "Http.Agent.TLS", "Http.Server", "Http.Server.TLS", - "Http.Server.Response" + "Http.Server.Response", + "Http.Client.Request" ], "native-modules": true, "dependencies": { @@ -52,10 +53,11 @@ "Fresheyeball/elm-restrict-number": "1.0.0 <= v < 2.0.0", "Fresheyeball/elm-tuple-extra": "1.0.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", "imeckler/either": "1.0.1 <= v < 2.0.0" }, "elm-version": "0.16.0 <= v < 0.17.0" -} \ No newline at end of file +} diff --git a/examples/HighLevel/AppServer/Main.elm b/examples/HighLevel/AppServer/Main.elm new file mode 100644 index 0000000..cfcf475 --- /dev/null +++ b/examples/HighLevel/AppServer/Main.elm @@ -0,0 +1,94 @@ +module Main (..) where + +import Effects 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 Console + + +(=>) : Task x a -> Task x b -> Task x b +(=>) t t' = + t `andThen` always t' + + +type alias RequestRaw = + Http.Types.Request + + +type alias ResponseRaw = + Http.Types.Response + + +type ServerAction action + = Incoming RequestRaw + | Outgoing ResponseRaw + | Cycle action + + +type alias Request = + { url : String + , method : Http.Types.METHOD + , statusCode : StatusCode + } + + +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 ) + + +respond : String -> ResponseRaw -> Task Never () +respond message res = + write (Debug.log "res" res) message => end res + + +port response : Signal (Task Never ()) +port response = + Signal.map (\( _, res ) -> respond "hello" res) connection.signal + + +port serve : Task Never () +port serve = + createServer + `andThen` \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.elm b/src/Http/Server.elm index a294c61..c9a53c9 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 @@ -53,13 +52,13 @@ Event: 'clientError' If a client connection emits an 'error' event, it will be forwarded here. socket is the net.Socket object that the error originated from. -} -onClientError : Server -> (Error -> Net.Socket -> Task x ()) -> Task x (Task x ()) +onClientError : Server -> (Net.Error -> Net.Socket -> Task x ()) -> Task x (Task x ()) onClientError server f = Emitter.on2 "clientError" server (\( rawErr, socket ) -> - f (Error <| Marshall.unsafeToString rawErr) socket + f (Net.Error <| Marshall.unsafeToString rawErr) socket ) @@ -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 -> (( IncomingRaw, 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 8bd39b2..4f4a271 100644 --- a/src/Http/Server/Request.elm +++ b/src/Http/Server/Request.elm @@ -1,6 +1,8 @@ module Http.Server.Request (..) where {-| +TODO EXPORT ME + 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. @@ -15,6 +17,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 +26,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 92bb320..64a1850 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 @@ -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 @@ -32,6 +33,20 @@ import Time exposing (Time) import Tuple import Json.Encode as Encode import Http.StatusCode exposing (StatusCode) +import Native.Network + + +{-| +NoOp response +-} +emptyResponse : Response +emptyResponse = + let + raw = Native.Network.emptyRes + in + { writable = Marshall.unsafeIdentity raw + , response = Marshall.unsafeIdentity raw + } {-| diff --git a/src/Native/Network.js b/src/Native/Network.js index dcc293d..ec9aa01 100644 --- a/src/Native/Network.js +++ b/src/Native/Network.js @@ -4,7 +4,19 @@ 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': function () { + return void 0; + }, + 'write': function () { + return void 0; + }, + 'writeHead': function () { + return void 0; + } + } }; })(); }; diff --git a/src/Native/Network.wisp b/src/Native/Network.wisp index 4c34321..a573e60 100644 --- a/src/Native/Network.wisp +++ b/src/Native/Network.wisp @@ -14,6 +14,12 @@ IPv6) raw.address)))) + :emptyReq {} + :emptyRes { + :end (fn [] nil) + :write (fn [] nil) + :writeHead (fn [] nil) } + } )))) (foreign.sanitize Elm :Native :Network) diff --git a/src/Server.elm b/src/Server.elm new file mode 100644 index 0000000..a28ffd9 --- /dev/null +++ b/src/Server.elm @@ -0,0 +1,44 @@ +module Server (..) where + +import Http.Types +import Http.Server.Request +import Http.Server.Response +import Http.Server exposing (createServer, listen, onRequest) +import Signal exposing (..) +import Task exposing (..) + + +type alias Request = + Http.Types.Request + + +type alias Response = + Http.Types.Response + + +type alias Server = + Http.Types.Server + + +emptyRequest : Request +emptyRequest = + Http.Server.Request.emptyRequest + + +emptyResponse : Response +emptyResponse = + Http.Server.Response.emptyResponse + + +(=>) : Task x a -> Task x b -> Task x b +(=>) t t' = + t `andThen` always t' + + +serve : Int -> Address ( Request, Response ) -> Task never Server +serve port' address = + createServer + `andThen` \server -> + listen server port' + => onRequest server (send address) + => succeed server diff --git a/src/Server/StartApp.elm b/src/Server/StartApp.elm new file mode 100644 index 0000000..2f8a0cd --- /dev/null +++ b/src/Server/StartApp.elm @@ -0,0 +1,89 @@ +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 Server exposing (..) + + +type alias Config model action = + { init : ( model, Effects action ) + , update : action -> model -> ( model, Effects action ) + , inputs : List (Signal action) + } + + +{-| +This type exists simply because +``` +type alias ServerConfig model action = + { Config model action | port' : Int } +``` +Is NOT valid Elm for some reason? +-} +type alias ServerConfigPlus x = + { x | port' : Int } + + +type alias ServerConfig model action = + { init : ( model, Effects (Action action) ) + , update : Action action -> model -> ( model, Effects (Action action) ) + , inputs : List (Signal action) + , port' : Int + } + + +type alias App model = + { model : Signal model + , tasks : Signal (Task Never ()) + } + + +type Action action + = Incoming Request + | Outgoing Response + | Cycle action + + +start : Config model action -> App model +start config = + let + singleton action = [ action ] + + -- messages : Signal.Mailbox (List action) + messages = + Signal.mailbox [] + + -- address : Signal.Address action + address = + Signal.forwardTo messages.address singleton + + -- 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 inputs + + model = + Signal.map fst effectsAndModel + in + { model = model + , tasks = Signal.map (Effects.toTask messages.address << snd) effectsAndModel + }