├── .gitignore ├── LICENSE ├── README.md ├── elm-package.json ├── example └── Main.elm ├── run.sh ├── runner.js └── src ├── HttpServer.elm ├── LowLevel.elm └── Native └── Server.js /.gitignore: -------------------------------------------------------------------------------- 1 | # elm-package generated files 2 | elm-stuff/ 3 | # elm-repl generated files 4 | repl-temp-* 5 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | BSD 3-Clause License 2 | 3 | Copyright (c) 2017, Noah 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | * Redistributions of source code must retain the above copyright notice, this 10 | list of conditions and the following disclaimer. 11 | 12 | * Redistributions in binary form must reproduce the above copyright notice, 13 | this list of conditions and the following disclaimer in the documentation 14 | and/or other materials provided with the distribution. 15 | 16 | * Neither the name of the copyright holder nor the names of its 17 | contributors may be used to endorse or promote products derived from 18 | this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 21 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 22 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 23 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 24 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 25 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 26 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 27 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 28 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # elm-http-server 2 | A HTTP server for Elm. 3 | 4 | :fire: :fire: :fire: expermimental. Don't use. :fire: :fire: 5 | 6 | 7 | 8 | Based on prior art: 9 | - [take-home](https://github.com/eeue56/take-home) by me 10 | - [servelm](https://github.com/eeue56/servelm) by me 11 | - [elm-http-server](https://github.com/RGBboy/elm-http-server) by RGBboy 12 | - [elm-http-server](https://github.com/fresheyeball/elm-http-server) by fresheyeball 13 | -------------------------------------------------------------------------------- /elm-package.json: -------------------------------------------------------------------------------- 1 | { 2 | "version": "1.0.0", 3 | "summary": "helpful summary of your project, less than 80 characters", 4 | "repository": "https://github.com/eeue56/elm-http-server.git", 5 | "license": "BSD3", 6 | "source-directories": [ 7 | "src" 8 | ], 9 | "exposed-modules": [], 10 | "dependencies": { 11 | "elm-lang/core": "5.1.1 <= v < 6.0.0", 12 | "elm-lang/html": "2.0.0 <= v < 3.0.0" 13 | }, 14 | "elm-version": "0.18.0 <= v < 0.19.0", 15 | "native-modules": true 16 | } -------------------------------------------------------------------------------- /example/Main.elm: -------------------------------------------------------------------------------- 1 | module Main exposing (..) 2 | 3 | import Platform 4 | import HttpServer 5 | 6 | 7 | main : Program Never Model Msg 8 | main = 9 | Platform.program 10 | { init = init 11 | , update = update 12 | , subscriptions = subscriptions 13 | } 14 | 15 | 16 | type alias Model = 17 | Int 18 | 19 | 20 | init : ( Model, Cmd Msg ) 21 | init = 22 | ( 0, Cmd.none ) 23 | 24 | 25 | type Msg 26 | = Request HttpServer.Request 27 | 28 | 29 | update : Msg -> Model -> ( Model, Cmd msg ) 30 | update message model = 31 | case message of 32 | Request request -> 33 | ( model + 1, HttpServer.respond request (toString model) ) 34 | 35 | 36 | subscriptions : Model -> Sub Msg 37 | subscriptions model = 38 | HttpServer.listen 8080 Request 39 | -------------------------------------------------------------------------------- /run.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | elm-make example/Main.elm --output main.js 4 | 5 | node runner.js -------------------------------------------------------------------------------- /runner.js: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env node 2 | 3 | var elm = require('./main.js'); 4 | 5 | elm.Main.worker(); -------------------------------------------------------------------------------- /src/HttpServer.elm: -------------------------------------------------------------------------------- 1 | effect module HttpServer 2 | where { command = MyCmd, subscription = MySub } 3 | exposing 4 | ( respond 5 | , listen 6 | , Request 7 | ) 8 | 9 | {-| 10 | 11 | @docs respond, listen, Request 12 | -} 13 | 14 | import Dict 15 | import Process 16 | import Task exposing (Task) 17 | import LowLevel as Http 18 | 19 | 20 | type alias Request = 21 | Http.Request 22 | 23 | 24 | 25 | -- COMMANDS 26 | 27 | 28 | type MyCmd msg 29 | = Respond Request String 30 | 31 | 32 | {-| Respond to a given request 33 | -} 34 | respond : Request -> String -> Cmd msg 35 | respond request message = 36 | command (Respond request message) 37 | 38 | 39 | cmdMap : (a -> b) -> MyCmd a -> MyCmd b 40 | cmdMap _ (Respond request msg) = 41 | Respond request msg 42 | 43 | 44 | 45 | -- SUBSCRIPTIONS 46 | 47 | 48 | type MySub msg 49 | = Listen Int (Request -> msg) 50 | 51 | 52 | {-| Subscribe to all requests that come in on a port 53 | -} 54 | listen : Int -> (Request -> msg) -> Sub msg 55 | listen portNumber tagger = 56 | subscription (Listen portNumber tagger) 57 | 58 | 59 | subMap : (a -> b) -> MySub a -> MySub b 60 | subMap func sub = 61 | case sub of 62 | Listen portNumber tagger -> 63 | Listen portNumber (tagger >> func) 64 | 65 | 66 | 67 | -- MANAGER 68 | 69 | 70 | type alias State msg = 71 | { servers : ServerDict 72 | , subs : SubsDict msg 73 | } 74 | 75 | 76 | type alias ServerDict = 77 | Dict.Dict Int Server 78 | 79 | 80 | type alias SubsDict msg = 81 | Dict.Dict Int (List (Request -> msg)) 82 | 83 | 84 | type Server 85 | = Opening Process.Id 86 | | Listening Http.Server 87 | 88 | 89 | init : Task Never (State msg) 90 | init = 91 | Task.succeed (State Dict.empty Dict.empty) 92 | 93 | 94 | 95 | -- HANDLE APP MESSAGES 96 | 97 | 98 | (&>) : Task x a -> Task x b -> Task x b 99 | (&>) t1 t2 = 100 | t1 101 | |> Task.andThen (\_ -> t2) 102 | 103 | 104 | onEffects : 105 | Platform.Router msg Msg 106 | -> List (MyCmd msg) 107 | -> List (MySub msg) 108 | -> State msg 109 | -> Task Never (State msg) 110 | onEffects router cmds subs state = 111 | let 112 | newSubs = 113 | buildSubDict subs Dict.empty 114 | 115 | cleanup _ = 116 | let 117 | newEntries = 118 | (Dict.map (\k v -> []) newSubs) 119 | 120 | leftStep portNumber _ getNewServers = 121 | getNewServers 122 | |> Task.andThen 123 | (\newServers -> 124 | attemptOpen router portNumber 125 | |> Task.andThen 126 | (\pid -> 127 | Task.succeed (Dict.insert portNumber (Opening pid) newServers) 128 | ) 129 | ) 130 | 131 | bothStep portNumber _ server getNewServers = 132 | Task.map (Dict.insert portNumber server) getNewServers 133 | 134 | rightStep portNumber server getNewServers = 135 | close server &> getNewServers 136 | in 137 | Dict.merge leftStep bothStep rightStep newEntries state.servers (Task.succeed Dict.empty) 138 | |> Task.andThen (\newServers -> Task.succeed (State newServers newSubs)) 139 | in 140 | sendReplies cmds 141 | |> Task.andThen cleanup 142 | 143 | 144 | sendReplies : List (MyCmd msg) -> Task x () 145 | sendReplies cmds = 146 | case cmds of 147 | [] -> 148 | Task.succeed () 149 | 150 | (Respond request msg) :: rest -> 151 | Http.respond request msg 152 | &> sendReplies rest 153 | 154 | 155 | buildSubDict : List (MySub msg) -> SubsDict msg -> SubsDict msg 156 | buildSubDict subs dict = 157 | case subs of 158 | [] -> 159 | dict 160 | 161 | (Listen portNumber tagger) :: rest -> 162 | buildSubDict rest (Dict.update portNumber (add tagger) dict) 163 | 164 | 165 | add : a -> Maybe (List a) -> Maybe (List a) 166 | add value maybeList = 167 | case maybeList of 168 | Nothing -> 169 | Just [ value ] 170 | 171 | Just list -> 172 | Just (value :: list) 173 | 174 | 175 | 176 | -- HANDLE SELF MESSAGES 177 | 178 | 179 | type Msg 180 | = Request Int Request 181 | | Die Int 182 | | Open Int Http.Server 183 | 184 | 185 | onSelfMsg : Platform.Router msg Msg -> Msg -> State msg -> Task Never (State msg) 186 | onSelfMsg router selfMsg state = 187 | case selfMsg of 188 | Request portNumber request -> 189 | let 190 | requests = 191 | Dict.get portNumber state.subs 192 | |> Maybe.withDefault [] 193 | |> List.map (\tagger -> Platform.sendToApp router (tagger request)) 194 | in 195 | Task.sequence requests 196 | &> Task.succeed state 197 | 198 | Die portNumber -> 199 | case Dict.get portNumber state.servers of 200 | Nothing -> 201 | Task.succeed state 202 | 203 | Just _ -> 204 | attemptOpen router portNumber 205 | |> Task.andThen 206 | (\pid -> Task.succeed (updateServer portNumber (Opening pid) state)) 207 | 208 | Open portNumber server -> 209 | Task.succeed (updateServer portNumber (Listening server) state) 210 | 211 | 212 | removeServer : Int -> State msg -> State msg 213 | removeServer portNumber state = 214 | { state | servers = Dict.remove portNumber state.servers } 215 | 216 | 217 | updateServer : Int -> Server -> State msg -> State msg 218 | updateServer portNumber server state = 219 | { state | servers = Dict.insert portNumber server state.servers } 220 | 221 | 222 | attemptOpen : Platform.Router msg Msg -> Int -> Task x Process.Id 223 | attemptOpen router portNumber = 224 | open router portNumber 225 | |> Task.andThen (Platform.sendToSelf router << Open portNumber) 226 | |> Process.spawn 227 | 228 | 229 | open : Platform.Router msg Msg -> Int -> Task x Http.Server 230 | open router portNumber = 231 | Http.listen portNumber 232 | { onRequest = \request -> Platform.sendToSelf router (Request portNumber request) 233 | , onClose = \_ -> Platform.sendToSelf router (Die portNumber) 234 | } 235 | 236 | 237 | close : Server -> Task x () 238 | close server = 239 | case server of 240 | Opening pid -> 241 | Process.kill pid 242 | 243 | Listening server -> 244 | Http.close server 245 | -------------------------------------------------------------------------------- /src/LowLevel.elm: -------------------------------------------------------------------------------- 1 | module LowLevel 2 | exposing 3 | ( listen 4 | , Settings 5 | , respond 6 | , close 7 | , Server 8 | , Request 9 | ) 10 | 11 | import Task exposing (Task) 12 | import Json.Encode as Json 13 | import Native.Server 14 | 15 | 16 | type Server 17 | = Server 18 | 19 | 20 | type alias RequestRecord = 21 | { request : Json.Value 22 | , response : Json.Value 23 | } 24 | 25 | 26 | type Request 27 | = Request RequestRecord 28 | 29 | 30 | {-| Attempt to listen to a particular port. 31 | -} 32 | listen : Int -> Settings -> Task x Server 33 | listen portNumber settings = 34 | Native.Server.listen portNumber settings 35 | 36 | 37 | {-| 38 | -} 39 | type alias Settings = 40 | { onRequest : Request -> Task Never () 41 | , onClose : () -> Task Never () 42 | } 43 | 44 | 45 | {-| Respond to the request with the given body 46 | -} 47 | respond : Request -> String -> Task x () 48 | respond request body = 49 | Native.Server.respond request body 50 | 51 | 52 | {-| Close a server's connection 53 | -} 54 | close : Server -> Task x () 55 | close = 56 | Native.Server.close 57 | -------------------------------------------------------------------------------- /src/Native/Server.js: -------------------------------------------------------------------------------- 1 | var _eeue56$elm_http_server$Native_Server = function(){ 2 | const http = require('http'); 3 | 4 | function listen (port, settings) { 5 | return _elm_lang$core$Native_Scheduler.nativeBinding(function (callback) { 6 | 7 | var server = http.createServer(); 8 | 9 | server.on('listening', function () { 10 | callback(_elm_lang$core$Native_Scheduler.succeed(server)); 11 | 12 | }); 13 | 14 | server.on('request', function (req, res) { 15 | var request = { 16 | ctor: "Request", 17 | _0: { 18 | request: req, 19 | response: res 20 | } 21 | }; 22 | _elm_lang$core$Native_Scheduler.rawSpawn(settings.onRequest(request)); 23 | }); 24 | 25 | server.on('close', function () { 26 | _elm_lang$core$Native_Scheduler.rawSpawn(settings.onClose()); 27 | }); 28 | 29 | server.listen(port); 30 | 31 | return; 32 | }); 33 | } 34 | 35 | function respond (request, string) { 36 | return _elm_lang$core$Native_Scheduler.nativeBinding(function (callback) { 37 | request._0.response.end(string); 38 | callback(_elm_lang$core$Native_Scheduler.succeed({ ctor: '_Tuple0' })); 39 | }); 40 | } 41 | 42 | function close (server) { 43 | return _elm_lang$core$Native_Scheduler.nativeBinding(function (callback) { 44 | server.close(); 45 | callback(_elm_lang$core$Native_Scheduler.succeed({ ctor: '_Tuple0' })); 46 | }); 47 | } 48 | 49 | return { 50 | listen: F2(listen), 51 | respond: F2(respond), 52 | close: close 53 | }; 54 | }(); 55 | 56 | --------------------------------------------------------------------------------