App server

elm-package.json

@@ -44,18 +44,20 @@
         "Http.Agent.TLS",
         "Http.Server",
         "Http.Server.TLS",
-        "Http.Server.Response"
+        "Http.Server.Response",
+        "Http.Client.Request"
     ],
     "native-modules": true,
     "dependencies": {
         "Fresheyeball/elm-cardinal": "1.0.0 <= v < 2.0.0",
         "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"
-}
+}

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 ()

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

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 ))
 
 
 {-|

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.

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
+        }
 
 
 {-|

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;
+                }
+            }
         };
     })();
 };

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)

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

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
+        }