├── .gitignore ├── .travis.yml ├── LICENSE ├── README.md ├── index.html ├── man ├── compat.htm ├── n2o.htm ├── server.htm └── websocket.htm ├── n2o-win.cm ├── n2o.cm ├── n2o.mlb ├── src ├── compat.sml ├── main-mlton.sml ├── main-smlnj.sml ├── main-win.sml ├── n2o.sml ├── server.fun ├── server.sml ├── sha1.sml ├── utf8.sml └── websocket.sml └── static ├── html └── index.html └── js └── main.js /.gitignore: -------------------------------------------------------------------------------- 1 | *.exe 2 | .#* 3 | .cm 4 | watch.sh 5 | *.nj.* 6 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # sudo: false 2 | language: generic 3 | 4 | addons: 5 | apt: 6 | packages: 7 | # - mlton 8 | - mlton-compiler 9 | - smlnj 10 | - libcml-smlnj 11 | - libcmlutil-smlnj 12 | - libsmlnj-smlnj 13 | 14 | cache: 15 | directories: 16 | - $HOME/.mlton 17 | 18 | before_install: 19 | #- git clone https://github.com/MLton/mlton MLton/mlton 20 | #- cd MLton/mlton 21 | #- make 22 | #- sudo make PREFIX=$HOME/.mlton install 23 | - export PATH=$HOME/.mlton/bin:$PATH 24 | 25 | script: 26 | - mlton 27 | - uname -a 28 | - mlton -output n2o.exe n2o.mlb 29 | - ml-build n2o.cm Main.main n2o.nj 30 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2013-2018 Marat Khafizov 2 | Copyright (c) 2013-2018 Maxim Sokhatsky 3 | 4 | Permission to use, copy, modify, and/or distribute this software for any 5 | purpose with or without fee is hereby granted, provided that the above 6 | copyright notice and this permission notice appear in all copies. 7 | 8 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | N2O for Standard ML 2 | =================== 3 | 4 | Here is example echo server, using N2O HTTP static and WebSocket servers. 5 | 6 | Build 7 | ----- 8 | [![Build Status](https://travis-ci.org/o1/n2o.svg?branch=master)](https://travis-ci.org/o1/n2o) 9 | 10 | Unix, Linux, Mac: 11 | 12 | ```bash 13 | $ mlton n2o.mlb && ./n2o 14 | $ ml-build n2o.cm Main.main n2o.nj && sml @SMLload=n2o.nj 15 | ``` 16 | 17 | Windows: 18 | 19 | ```bash 20 | $ ml-build n2o-win.cm Main.main n2o-win.nj && sml @SMLload=n2o-win.nj 21 | ``` 22 | 23 | Run 24 | --- 25 | 26 | Open http://localhost:8989 or use `wscat` 27 | 28 | ``` 29 | $ wscat -c ws://127.0.0.1:8989/ws/ 30 | connected (press CTRL+C to quit) 31 | > helo 32 | < helo 33 | ``` 34 | 35 | Measure 36 | ------- 37 | 38 | ``` 39 | $ tcpkali -T20s -r 100000 -c 2 -m PING —latency-marker "PING" —ws 127.0.0.1:8989/ws 40 | Destination: [127.0.0.1]:8989 41 | Interface lo address [127.0.0.1]:0 42 | Using interface lo to connect to [127.0.0.1]:8989 43 | Ramped up to 2 connections. 44 | Total data sent: 33.0 MiB (34637100 bytes) 45 | Total data received: 18.4 MiB (19263720 bytes) 46 | Bandwidth per channel: 10.779⇅ Mbps (1347.4 kBps) 47 | Aggregate bandwidth: 7.705↓, 13.853↑ Mbps 48 | Packet rate estimate: 23465.4↓, 1327.3↑ (1↓, 1↑ TCP MSS/op) 49 | Message latency at percentiles: 5043.1/5327.9/5375.9 ms (95/99/99.5%) 50 | Test duration: 20.0022 s. 51 | ``` 52 | 53 | Credits 54 | ------- 55 | 56 | * Marat Khafizov 57 | * Maxim Sokhatsky 58 | -------------------------------------------------------------------------------- /index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | N2O 9 | 10 | 11 | 12 | 13 | 18 |
19 | 20 |

N2O

21 |
22 | 48 |
49 |
50 |

N2O for Standard ML

51 |
52 |
53 |
54 | Made with ❤ to Standard ML 55 |
56 | 57 | 58 | -------------------------------------------------------------------------------- /man/compat.htm: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | COMPAT 10 | 11 | 12 | 13 | 14 | 15 | 16 | 21 | 22 |
23 | 24 |

COMPAT

25 |
26 | 27 |
28 |
29 |

INTRO

30 |

The compat module provides binary compatibility API for SML/NJ and MLton.

31 |
32 |
33 |

API

34 |

w8_to_w64

35 |

w64_to_w8

36 |

pack_w64be

37 |

extract_w16be

38 |

extract_w64be

39 |
40 | 41 |
42 | 43 |
44 | Made with ❤ to Standard ML 45 |
46 | 47 | 48 | 49 | -------------------------------------------------------------------------------- /man/n2o.htm: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | N2O 10 | 11 | 12 | 13 | 14 | 15 | 16 | 21 | 22 |
23 | 24 |

N2O

25 |
26 | 27 |
28 |
29 |

INTRO

30 |

The n2o module contains request and context definition, state and N2O functors.

31 |
32 |
33 |

REQUEST

34 |
Listing 1. HTTP Request
35 | type Req = { path : string 36 | , method : string 37 | , version : string 38 | , headers : (string * string) list 39 | } 40 |
41 |
Listing 2. HTTP Request Constructor
42 | fun mkReq () = { path = "" 43 | , method = "" 44 | , version = "HTTP/1.1" 45 | , headers = [] 46 | } 47 |
48 |
49 |
50 |

CONTEXT

51 |
Listing 3. N2O Protocol Closure
52 | datatype 'a Ev = Init 53 | | Message of 'a 54 | | Terminate 55 |
56 |
Listing 4. N2O Protocol Result
57 | datatype 'a Res = Reply of 'a 58 | | Ok 59 | | Unknown 60 | | Empty 61 |
62 |
Listing 5. N2O Context Record
63 | type 'a Cx = { req : Req 64 | , module : 'a Ev -> 'a Res 65 | } 66 | 67 | val 'a mod_ : 'a Ev -> 'a Res = fn _ => Empty 68 | 69 | signature BASE = sig 70 | type t 71 | type 'a prot 72 | end 73 | 74 | signature BASE_EXT = sig 75 | include BASE 76 | val handlers : (t Hnd) list 77 | val protos : ((t prot) Proto) list 78 | end 79 | 80 | signature CX = sig 81 | include BASE_EXT 82 | val cx : t Cx 83 | end 84 |
85 |
Listing 6. N2O Context Constructor
86 | functor MkCx (M: BASE_EXT) :> CX = struct 87 | type t = M.t 88 | type 'a prot = 'a M.prot 89 | val cx = { req = mkReq (), module = mod_ } 90 | val handlers = M.handlers 91 | val protos = M.protos 92 | end 93 |
94 |
95 |
96 |

IO

97 |
Listing 7. N2O PROTO
98 | type 'a Proto = 'a -> 'a Res 99 | type 'a Hnd = 'a Cx -> 'a Cx 100 |
101 |
102 |
103 |

This module may refer to: 104 | SERVER 105 |

106 |
107 |
108 | 109 |
110 | Made with ❤ to Standard ML 111 |
112 | 113 | 114 | 115 | -------------------------------------------------------------------------------- /man/server.htm: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | SERVER 10 | 11 | 12 | 13 | 14 | 15 | 16 | 21 | 22 |
23 | 24 |

SERVER

25 |
26 | 27 |
28 |
29 |

INTRO

30 |

The server module provides static HTTP and WebSocket server.

31 |
32 |
33 |

IO

34 |
Listing 1. Request
35 | type Req = { cmd : string, 36 | path : string, 37 | headers : (string*string) list, vers : string } 38 |
39 |
Listing 1. Response
40 | type Resp = { status : int, 41 | headers : (string*string) list, 42 | body : Word8Vector.vector } 43 |
44 |
45 |
46 | 47 |
48 | Made with ❤ to Standard ML 49 |
50 | 51 | 52 | 53 | -------------------------------------------------------------------------------- /man/websocket.htm: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | WEBSOCKET 9 | 10 | 11 | 12 | 13 | 18 |
19 | 20 |

WEBSOCKET

21 |
22 |
23 |
24 |

INTRO

25 |

The websocket module provides RFC 6455 functions.

26 |
Listing 1. Frame Type
27 | datatype FrameType = Cont | Text | Bin | Close | Ping | Pong 28 |
29 |
Listing 2. Frame
30 | type Frame = { fin : bool, 31 | rsv1 : bool, rsv2 : bool, rsv3 : bool, 32 | typ : FrameType, 33 | payload : Word8Vector.vector } 34 |
35 |
36 |
37 |

API

38 |

39 |

serve : Socket ->

40 |
41 |
42 |
43 | Made with ❤ to Standard ML 44 |
45 | 46 | 47 | -------------------------------------------------------------------------------- /n2o-win.cm: -------------------------------------------------------------------------------- 1 | Group is 2 | $cml/basis.cm 3 | $cml/cml.cm 4 | $cml-lib/smlnj-lib.cm 5 | src/n2o.sml 6 | src/websocket.sml 7 | src/server.fun 8 | src/server.sml 9 | src/utf8.sml 10 | src/compat.sml 11 | src/sha1.sml 12 | src/main-win.sml 13 | -------------------------------------------------------------------------------- /n2o.cm: -------------------------------------------------------------------------------- 1 | Group is 2 | $cml/basis.cm 3 | $cml/cml.cm 4 | $cml-lib/smlnj-lib.cm 5 | src/n2o.sml 6 | src/websocket.sml 7 | src/server.fun 8 | src/server.sml 9 | src/utf8.sml 10 | src/compat.sml 11 | src/sha1.sml 12 | src/main-smlnj.sml 13 | -------------------------------------------------------------------------------- /n2o.mlb: -------------------------------------------------------------------------------- 1 | $(SML_LIB)/basis/basis.mlb 2 | $(SML_LIB)/basis/mlton.mlb 3 | $(SML_LIB)/cml/cml.mlb 4 | $(SML_LIB)/smlnj-lib/Util/smlnj-lib.mlb 5 | src/compat.sml 6 | src/sha1.sml 7 | src/n2o.sml 8 | src/websocket.sml 9 | src/server.fun 10 | src/server.sml 11 | src/main-mlton.sml 12 | src/utf8.sml 13 | -------------------------------------------------------------------------------- /src/compat.sml: -------------------------------------------------------------------------------- 1 | structure Compat = struct 2 | 3 | structure A = Word8Array 4 | structure V = Word8Vector 5 | structure W8 = Word8 6 | structure W64 = Word64 7 | 8 | val w8_to_w64 = 9 | if LargeWord.wordSize = 64 10 | then W64.fromLarge o W8.toLarge 11 | else W64.fromLargeInt o W8.toLargeInt 12 | 13 | val w64_to_w8 = 14 | if LargeWord.wordSize = 64 15 | then W8.fromLarge o W64.toLarge 16 | else W8.fromLargeInt o W64.toLargeInt 17 | 18 | local 19 | val orb = W64.orb 20 | val (op-) = Int.- 21 | val (op+) = Int.+ 22 | infix orb + - 23 | in 24 | 25 | fun pack_w16be (arr,i,w) = 26 | (A.update (arr, i, w64_to_w8(Word64.>>(w,0w8))); 27 | A.update (arr, i+1, w64_to_w8(w))) 28 | 29 | fun pack_w64be (arr,i,w) = 30 | (A.update (arr, i, w64_to_w8(Word64.>>(w,0w56))); 31 | A.update (arr, i+1, w64_to_w8(Word64.>>(w,0w48))); 32 | A.update (arr, i+2, w64_to_w8(Word64.>>(w,0w40))); 33 | A.update (arr, i+3, w64_to_w8(Word64.>>(w,0w32))); 34 | A.update (arr, i+4, w64_to_w8(Word64.>>(w,0w24))); 35 | A.update (arr, i+5, w64_to_w8(Word64.>>(w,0w16))); 36 | A.update (arr, i+6, w64_to_w8(Word64.>>(w,0w8))); 37 | A.update (arr, i+7, w64_to_w8(w))) 38 | 39 | fun extract_w16be vec = 40 | let 41 | val p0 = W64.<<(w8_to_w64(V.sub(vec,0)),0w8) 42 | val p1 = w8_to_w64(V.sub(vec,1)) 43 | in 44 | p0 orb p1 45 | end 46 | 47 | fun extract_w64be vec = 48 | let 49 | val p0 = W64.<<(w8_to_w64(V.sub(vec,0)),0w56) 50 | val p1 = W64.<<(w8_to_w64(V.sub(vec,1)),0w48) 51 | val p2 = W64.<<(w8_to_w64(V.sub(vec,2)),0w40) 52 | val p3 = W64.<<(w8_to_w64(V.sub(vec,3)),0w32) 53 | val p4 = W64.<<(w8_to_w64(V.sub(vec,4)),0w24) 54 | val p5 = W64.<<(w8_to_w64(V.sub(vec,5)),0w16) 55 | val p6 = W64.<<(w8_to_w64(V.sub(vec,6)),0w8) 56 | val p7 = w8_to_w64(V.sub(vec,7)) 57 | in 58 | p0 orb p1 orb p2 orb p3 orb p4 orb p5 orb p6 orb p7 59 | end 60 | end 61 | end 62 | 63 | structure CompatTest = struct 64 | 65 | fun test() = 66 | let val exp = Word8Vector.fromList[0wxAA,0wxBB] 67 | val arr = Word8Array.array(2,0w0); 68 | fun fmt v i = Word8.toString (Word8Vector.sub(v,i)) 69 | val _ = Compat.pack_w16be(arr,0,0wxAABB) 70 | val act = Word8Array.vector arr 71 | in if exp = act then () 72 | else raise Fail ("Expected: AABB\nActual: " ^ (fmt act 0) ^ (fmt act 1)) 73 | end 74 | 75 | end 76 | 77 | val _ = CompatTest.test() 78 | -------------------------------------------------------------------------------- /src/main-mlton.sml: -------------------------------------------------------------------------------- 1 | structure Main = struct 2 | open MLton.Signal 3 | fun main (program_name, arglist) = 4 | (setHandler (Posix.Signal.pipe, Handler.ignore); 5 | RunCML.doit (fn () => Server.run(program_name, arglist), NONE); 6 | OS.Process.success) 7 | end 8 | 9 | val _ = Main.main ("test", nil) 10 | -------------------------------------------------------------------------------- /src/main-smlnj.sml: -------------------------------------------------------------------------------- 1 | structure Main = struct 2 | open TextIO 3 | fun main (program_name, arglist) = 4 | (UnixSignals.setHandler (UnixSignals.sigPIPE, UnixSignals.IGNORE); 5 | RunCML.doit (fn () => Server.run(program_name, arglist), NONE); 6 | OS.Process.success) 7 | end 8 | -------------------------------------------------------------------------------- /src/main-win.sml: -------------------------------------------------------------------------------- 1 | structure Main = struct 2 | open TextIO 3 | fun main (program_name, arglist) = 4 | (RunCML.doit (fn () => Server.run(program_name, arglist), NONE); 5 | OS.Process.success) 6 | end 7 | -------------------------------------------------------------------------------- /src/n2o.sml: -------------------------------------------------------------------------------- 1 | signature PROTO = sig 2 | type Prot (* Input type for protocol handler *) 3 | type Ev (* Output type for protocol handler and input type for event handler *) 4 | type Res type Req 5 | val proto : Prot -> Ev 6 | end 7 | 8 | functor MkN2O(M : PROTO) = struct 9 | type Cx = {req: M.Req, module: M.Ev -> M.Res} 10 | fun fold cx [] = cx 11 | | fold cx (head::tail) = 12 | let val cx1 = head cx in 13 | fold cx1 tail end 14 | fun run (cx : Cx) (handlers : (Cx -> Cx) list) (msg : M.Prot) = 15 | let val cx1 = fold cx handlers in 16 | (#module cx1) (M.proto msg) end 17 | end 18 | -------------------------------------------------------------------------------- /src/server.fun: -------------------------------------------------------------------------------- 1 | structure HTTP = struct 2 | type Headers = (string*string) list 3 | type Req = { cmd : string, 4 | path : string, 5 | headers : Headers, vers : string } 6 | type Resp = { status : int, 7 | headers : Headers, 8 | body : Word8Vector.vector } 9 | end 10 | 11 | signature HANDLER = sig 12 | val hnd : HTTP.Req*WebSocket.Msg -> WebSocket.Res 13 | end 14 | 15 | functor MkServer(M : HANDLER) = struct 16 | 17 | type Req = HTTP.Req 18 | type Resp = HTTP.Resp 19 | 20 | exception BadRequest of string 21 | exception NotFound of string 22 | 23 | fun collect mark i sl acc slc = 24 | if i > (mark + sl) 25 | then (Word8VectorSlice.subslice (slc, mark, SOME ((i-mark)-sl)))::acc 26 | else acc 27 | 28 | fun recur s l len sl mark i [] acc = 29 | recur s l len sl i i l (collect mark i sl acc s) 30 | | recur s l len sl mark i (b::bs) acc = 31 | if i = len 32 | then List.rev (collect mark i 0 acc s) 33 | else recur s l len sl mark (i+1) 34 | (if b = Word8VectorSlice.sub (s, i) then bs else l) acc 35 | 36 | fun tokens slc (sep : string) = 37 | let val lst = map (Word8.fromInt o Char.ord) (String.explode sep) 38 | val len = Word8VectorSlice.length slc 39 | in recur slc lst len (String.size sep) 0 0 lst [] 40 | end 41 | 42 | val sliceToStr = Byte.bytesToString o Word8VectorSlice.vector 43 | fun tokens' slc (sep : string) = map sliceToStr (tokens slc sep) 44 | 45 | fun parseHeaders nil = nil 46 | | parseHeaders (ln::lns) = (case tokens' ln ": " of 47 | k::v::_ => (k,v) 48 | | _ => raise BadRequest "Invalid headers") 49 | :: (parseHeaders lns) 50 | 51 | fun writeHeaders nil = "" 52 | | writeHeaders ((k,v)::hs) = k ^ ": " ^ v ^ "\r\n" ^ (writeHeaders hs) 53 | 54 | fun parseReq slc : Req = 55 | case tokens slc "\r\n" of 56 | nil => raise BadRequest "Malformed HTTP request" 57 | | lines as (hd::tl) => 58 | case tokens' hd " " of 59 | "GET"::path::vers::_ => { cmd = "GET", path = path, headers = parseHeaders tl, vers = vers } 60 | | _ => raise BadRequest "Method must be GET" 61 | 62 | fun lower str = String.map Char.toLower str 63 | fun header nam (req : Req) = List.find (fn (k,v) => lower k = lower nam) (#headers req) 64 | fun needUpgrade req = 65 | case header "Upgrade" req of 66 | SOME (_,v) => (lower v) = "websocket" 67 | | _ => false 68 | 69 | fun getKey req = 70 | case header "Sec-WebSocket-Key" req of 71 | NONE => raise BadRequest "No Sec-WebSocket-Key header" 72 | | SOME (_,key) => let val magic = "258EAFA5-E914-47DA-95CA-C5AB0DC85B11" 73 | in Base64.encode(SHA1.encode(Byte.stringToBytes(key^magic))) end 74 | 75 | fun checkHandshake req = 76 | (if #cmd req <> "GET" then raise BadRequest "Method must be GET" else (); 77 | if #vers req <> "HTTP/1.1" then raise BadRequest "HTTP version must be 1.1" else (); 78 | case header "Sec-WebSocket-Version" req of 79 | SOME (_,"13") => () 80 | | _ => raise BadRequest "WebSocket version must be 13") 81 | 82 | fun upgrade sock req = 83 | (checkHandshake req; 84 | { body = Word8Vector.fromList nil, 85 | status = 101, headers = [("Upgrade", "websocket"), 86 | ("Connection", "Upgrade"), 87 | ("Sec-WebSocket-Accept", getKey req)] }) 88 | 89 | fun sendBytes sock bytes = ignore (Socket.sendVec (sock, Word8VectorSlice.full bytes)) 90 | fun sendStr sock str = sendBytes sock (Byte.stringToBytes str) 91 | fun sendList sock lst = sendStr sock (String.concat lst) 92 | 93 | fun fileResp filePath = 94 | let val stream = BinIO.openIn filePath 95 | val data = BinIO.inputAll stream 96 | val () = BinIO.closeIn stream 97 | in { status = 200, body = data, 98 | headers = [("Content-Type", "text/html"), 99 | ("Content-Length", Int.toString (Word8Vector.length data))] } 100 | end 101 | 102 | fun respCode 101 = "Switching Protocols" 103 | | respCode 200 = "OK" 104 | | respCode 400 = "Bad Request" 105 | | respCode 404 = "Not Found" 106 | | respCode _ = "Internal Server Error" 107 | 108 | fun sendResp sock {status=status,headers=headers,body=body} = 109 | (sendList sock ["HTTP/1.1 ", Int.toString status, 110 | " ", respCode status, "\r\n", 111 | writeHeaders headers, "\r\n"]; 112 | sendBytes sock body) 113 | 114 | fun sendError sock code body = 115 | (print body; 116 | sendResp sock {status=code,headers=[],body=Byte.stringToBytes body}; 117 | Socket.close sock) 118 | 119 | fun router path = 120 | case path of 121 | "/" => "/index" 122 | | p => if String.isPrefix "/ws" p 123 | then String.extract (p, 3, NONE) 124 | else p 125 | 126 | fun serve sock : Req*Resp = 127 | let val req = parseReq (Word8VectorSlice.full (Socket.recvVec (sock, 2048))) 128 | val path = #path req 129 | val reqPath = router path 130 | in if needUpgrade req then (req, upgrade sock req) 131 | else (req, fileResp ("static/html" ^ reqPath ^ ".html")) 132 | handle Io => (req, fileResp (String.extract (path, 1, NONE))) 133 | handle Io => raise NotFound path 134 | end 135 | 136 | fun switch sock = 137 | case serve sock of 138 | (req, resp) => (sendResp sock resp; 139 | if (#status resp) <> 101 140 | then ignore (Socket.close sock) 141 | else WebSocket.serve sock (fn msg => (M.hnd (req,msg)))) 142 | 143 | fun connMain sock = 144 | switch sock 145 | handle BadRequest err => sendError sock 400 ("Bad Request: " ^ err ^ "\n") 146 | | NotFound path => sendError sock 404 ("Not Found: " ^ path ^ "\n") 147 | 148 | fun acceptLoop server_sock = 149 | let val (s, _) = Socket.accept server_sock 150 | in (*print "Accepted a connection.\n";*) 151 | CML.spawn (fn () => connMain(s)); 152 | acceptLoop server_sock 153 | end 154 | 155 | fun run (program_name, arglist) = 156 | let val s = INetSock.TCP.socket() 157 | in Socket.Ctl.setREUSEADDR (s, true); 158 | Socket.bind(s, INetSock.any 8989); 159 | Socket.listen(s, 5); 160 | print "n2o server...\n"; 161 | acceptLoop s 162 | end 163 | end 164 | -------------------------------------------------------------------------------- /src/server.sml: -------------------------------------------------------------------------------- 1 | structure EchoProto : PROTO = struct 2 | type Prot = WebSocket.Msg 3 | type Ev = Word8Vector.vector option 4 | type Res = WebSocket.Res 5 | type Req = HTTP.Req 6 | fun proto (WebSocket.TextMsg s) = SOME s 7 | | proto _ = NONE 8 | end 9 | structure Echo = MkN2O(EchoProto) 10 | 11 | structure EchoHandler : HANDLER = struct 12 | 13 | fun noop _ = WebSocket.Ok 14 | fun echo NONE = WebSocket.Ok 15 | | echo (SOME s) = WebSocket.Reply (WebSocket.TextMsg s) 16 | fun router (cx : Echo.Cx) = 17 | {req=(#req cx),module=echo} 18 | fun hnd (req,msg) = 19 | Echo.run {req=req,module=noop} [router] msg 20 | end 21 | 22 | structure Server = MkServer(EchoHandler) 23 | -------------------------------------------------------------------------------- /src/sha1.sml: -------------------------------------------------------------------------------- 1 | structure SHA1 = struct 2 | 3 | type w32 = Word32.word 4 | type hw32 = w32*w32*w32*w32*w32 5 | 6 | structure V = Word8Vector 7 | structure VS = Word8VectorSlice 8 | structure A = Word8Array 9 | structure W64 = Word64 10 | 11 | val xorb = Word32.xorb 12 | infixr 5 xorb 13 | 14 | val hinit : hw32 = (0wx67452301,0wxefcdab89,0wx98badcfe,0wx10325476,0wxc3d2e1f0) 15 | 16 | fun pad bs = 17 | let open W64 18 | val len = V.length bs 19 | val bitlen = W64.*(W64.fromInt len,0w8) 20 | val lstbl = bitlen mod 0w512 21 | val addlen = if lstbl < 0w448 then ((0w448 - lstbl) div 0w8) + 0w8 22 | else ((0w512 - lstbl) div 0w8) + 0w64 23 | val totlen = Int.+(len, toInt addlen) 24 | val arr = A.array (totlen, 0w0) 25 | in A.copyVec {src = bs, dst = arr, di = 0}; 26 | A.update (arr, len, 0wx80); 27 | Compat.pack_w64be (arr, Int.-(totlen,8), bitlen); 28 | A.vector arr end 29 | 30 | local open Word32 31 | infix orb xorb andb << >> 32 | in fun lrot (x,n) = (x << n) orb (x >> Word.-(0w32,n)) 33 | fun ch (b,c,d) = (b andb c) orb ((notb b) andb d) 34 | fun par (b,c,d) = b xorb c xorb d 35 | fun maj (b,c,d) = (b andb c) orb (b andb d) orb (c andb d) 36 | end 37 | 38 | fun fk t = 39 | if (00 <= t) andalso (t <= 19) then (ch, 0wx5a827999:w32) 40 | else if (20 <= t) andalso (t <= 39) then (par,0wx6ed9eba1) 41 | else if (40 <= t) andalso (t <= 59) then (maj,0wx8f1bbcdc) 42 | else if (60 <= t) andalso (t <= 79) then (par,0wxca62c1d6) 43 | else raise Fail "'t' is out of range" 44 | 45 | fun m bs i t : w32 = 46 | let val block = VS.slice (bs, 64*i + 4*t, SOME 4) 47 | val subv = VS.vector block 48 | in Word32.fromLarge (PackWord32Big.subVec (subv, 0)) end 49 | 50 | fun w bs i t = 51 | let val w' = w bs i 52 | in if (0 <= t) andalso (t <= 15) 53 | then m bs i t 54 | else if (16 <= t) andalso (t <= 79) 55 | then lrot(w'(t-3) xorb w'(t-8) xorb w'(t-14) xorb w'(t-16),0w1) 56 | else raise Fail "t is out of range" 57 | end 58 | 59 | fun loop_t wt t (h as (a,b,c,d,e)) = 60 | if (t = 80) then h 61 | else let open Word32 62 | val (f,k) = fk(t) 63 | val tmp = lrot(a,0w5) + f(b,c,d) + e + k + wt(t) 64 | in loop_t wt (Int.+(t,1)) (tmp,a,lrot(b,0w30),c,d) end 65 | 66 | fun loop_i bs i (res as (h0,h1,h2,h3,h4)) = 67 | if i = (V.length bs) div 64 then res 68 | else let val wt = w bs i 69 | val (a,b,c,d,e) = loop_t wt 0 (h0,h1,h2,h3,h4) 70 | in loop_i bs (i+1) (h0+a,h1+b,h2+c,h3+d,h4+e) end 71 | 72 | fun encode bs = 73 | let val (h0,h1,h2,h3,h4) = loop_i (pad bs) 0 hinit 74 | val arr = A.array (20,0w0) 75 | fun pack i x = PackWord32Big.update (arr,i,Word32.toLarge x) 76 | in pack 0 h0; pack 1 h1; pack 2 h2; pack 3 h3; pack 4 h4; 77 | A.vector arr end 78 | end 79 | 80 | structure SHA1Test = struct 81 | structure V = Word8Vector 82 | fun hexstr (vec:V.vector):string = 83 | V.foldr (fn (e,a) => (if (Word8.<= (e, 0wxf)) 84 | then "0" else "") ^ (Word8.toString e) ^ a) "" vec 85 | fun hex v = String.map Char.toLower (hexstr v) 86 | fun test (x, expected) = let 87 | val raw = Byte.stringToBytes x 88 | val actual = hex (SHA1.encode raw) 89 | in if expected = actual then () 90 | else raise Fail ("\nExpected: " ^ expected ^ "\n actual: " ^ actual ^ "\n") 91 | end 92 | end 93 | 94 | val _ = (SHA1Test.test("abcdef", "1f8ac10f23c5b5bc1167bda84b833e5c057a77d2")) 95 | -------------------------------------------------------------------------------- /src/utf8.sml: -------------------------------------------------------------------------------- 1 | (* UTF-8 Encoder/Decoder *) 2 | 3 | (* bitbucket.org/cannam/sml-utf8 4 | Copyright (c) 2015-2017 Chris Cannam (MIT license) *) 5 | 6 | structure Utf8Decoder :> sig 7 | val foldlString : (word * word list -> word list) -> word list -> string -> word list 8 | end = struct 9 | fun overlong n = 10 | case n of 11 | 2 => 0wx0080 12 | | 3 => 0wx0800 13 | | 4 => 0wx10000 14 | | _ => 0wx0 15 | 16 | fun foldlString f a s = 17 | let open Word 18 | infix 6 orb andb xorb << 19 | 20 | fun decode (byte, (n, i, cp, a)) = 21 | let val w = Word.fromLargeWord (Word8.toLargeWord byte) 22 | in case i of 23 | 0 => if (w andb 0wx80) = 0wx0 then (0, 0, 0wx0, f (w, a)) 24 | else if (w andb 0wxe0) = 0wxc0 then (2, 1, w xorb 0wxc0, a) 25 | else if (w andb 0wxf0) = 0wxe0 then (3, 2, w xorb 0wxe0, a) 26 | else if (w andb 0wxf8) = 0wxf0 then (4, 3, w xorb 0wxf0, a) 27 | else (0, 0, 0wx0, f (0wxfffd, a)) 28 | 29 | | 1 => if w andb 0wxc0 = 0wx80 then 30 | let val cp = (cp << 0w6) orb (w xorb 0wx80) 31 | in if cp < overlong n then (0, 0, 0wx0, f (0wxfffd, a)) 32 | else if cp > 0wx10ffff then (0, 0, 0wx0, f (0wxfffd, a)) 33 | else (0, 0, 0wx0, f (cp, a)) end 34 | else decode (byte, (0, 0, 0wx0, f (0wxfffd, a))) 35 | 36 | | i => if w andb 0wxc0 = 0wx80 then 37 | let val cp = (cp << 0w6) orb (w xorb 0wx80) 38 | in (n, Int.-(i, 1), cp, a) 39 | end else decode (byte, (0, 0, 0wx0, f (0wxfffd, a))) 40 | end 41 | in case Word8Vector.foldl decode (0, 0, 0wx0, a) (Byte.stringToBytes s) of 42 | (n, 0, 0wx0, result) => result 43 | | (n, i, cp, result) => f (0wxfffd, result) 44 | end 45 | end 46 | 47 | structure Utf8Encoder :> sig 48 | val codepointsToUtf8 : ((word * char list -> char list) -> char list -> 'a -> char list) -> 'a -> string 49 | val codepointToUtf8 : word -> char list 50 | end = struct 51 | open Word 52 | infix 6 orb andb >> 53 | val char = Char.chr o toInt 54 | fun prepend_utf8 (cp, acc) = 55 | if cp < 0wx80 then char cp :: acc 56 | else if cp < 0wx800 then 57 | char (0wxc0 orb (cp >> 0w6)) :: 58 | char (0wx80 orb (cp andb 0wx3f)) :: acc 59 | else if cp < 0wx10000 then 60 | char (0wxe0 orb (cp >> 0w12)) :: 61 | char (0wx80 orb ((cp >> 0w6) andb 0wx3f)) :: 62 | char (0wx80 orb (cp andb 0wx3f)) :: acc 63 | else if cp < 0wx10ffff then 64 | char (0wxf0 orb (cp >> 0w18)) :: 65 | char (0wx80 orb ((cp >> 0w12) andb 0wx3f)) :: 66 | char (0wx80 orb ((cp >> 0w6) andb 0wx3f)) :: 67 | char (0wx80 orb (cp andb 0wx3f)) :: acc 68 | else acc 69 | 70 | fun codepointToUtf8 cp = 71 | prepend_utf8 (cp, []) 72 | 73 | fun codepointsToUtf8 folder cps = 74 | String.implode (folder prepend_utf8 [] cps) 75 | 76 | end 77 | -------------------------------------------------------------------------------- /src/websocket.sml: -------------------------------------------------------------------------------- 1 | structure WebSocket = struct 2 | 3 | structure W8 = Word8 4 | structure W64 = Word64 5 | structure V = Word8Vector 6 | structure A = Word8Array 7 | structure AS = Word8ArraySlice 8 | 9 | datatype FrameType = Cont | Text | Bin | Close | Ping | Pong 10 | 11 | datatype Msg = TextMsg of V.vector (*TODO:utf8*) 12 | | BinMsg of V.vector 13 | | CloseMsg of Word32.word 14 | | ContMsg of V.vector 15 | | PingMsg 16 | | PongMsg 17 | 18 | datatype Res = Error of string 19 | | Reply of Msg 20 | | Ok 21 | 22 | type Frame = { fin : bool, 23 | rsv1 : bool, rsv2 : bool, rsv3 : bool, 24 | typ : FrameType, payload : V.vector } 25 | 26 | fun bytes sock n = Socket.recvVec (sock, n) 27 | fun w8 sock = V.sub (bytes sock 1, 0) 28 | fun w16 sock = Compat.extract_w16be (bytes sock 2) 29 | fun w64 sock = Compat.extract_w64be (bytes sock 8) 30 | 31 | fun check (len : W64.word) fin = 32 | if not fin then raise (Fail "Control frames must not be fragmented") 33 | else if len > 0w125 then raise (Fail "Control frames must not carry payload > 125 bytes") 34 | else () 35 | 36 | fun unmask (key,encoded) = 37 | V.mapi (fn (i,el) => W8.xorb(el,V.sub(key,i mod 4))) encoded 38 | 39 | fun opcode Text : Word8.word = 0wx1 40 | | opcode Bin = 0wx2 41 | | opcode Cont = 0wx0 42 | | opcode Close = 0wx8 43 | | opcode Ping = 0wx9 44 | | opcode Pong = 0wxA 45 | 46 | fun sndf sock ({fin,typ,payload,...} : Frame) : unit = 47 | let val len = V.length payload 48 | val (b1,di,pack) = if len < 126 then (W8.fromInt(len),2,fn _ => ()) 49 | else if len < 65535 then (0w126,4,Compat.pack_w16be) 50 | else (0w127,10,Compat.pack_w64be) 51 | val arr = A.array (len+di,0w0) 52 | in A.update(arr,0,W8.orb(0wx80,opcode typ)); 53 | A.update(arr,1,b1); 54 | pack(arr,2,W64.fromInt(len)); 55 | A.copyVec {src=payload,dst=arr,di=di}; 56 | Socket.sendArr(sock,AS.full(arr)); 57 | () 58 | end 59 | 60 | fun fr t b : Frame = {fin=true,rsv1=false,rsv2=false,rsv3=false,typ=t,payload=b} 61 | val emp : V.vector = V.fromList[] 62 | 63 | fun send sock msg = 64 | case msg of 65 | (TextMsg b) => sndf sock (fr Text b)(*TODO check length*) 66 | | (BinMsg b) => sndf sock (fr Bin b)(*TODO check length*) 67 | | (CloseMsg b) => let val arr = A.array(2,0w0) 68 | in PackWord16Big.update(arr,0,Word32.toLarge b); 69 | sndf sock (fr Close (A.vector arr)) end 70 | | PingMsg => sndf sock (fr Ping emp) 71 | | PongMsg => sndf sock (fr Pong emp) 72 | | _ => raise Fail "cont msg!" 73 | 74 | fun parse sock : Frame = 75 | let val b0 = w8 sock 76 | val (fin, rsv1) = (W8.andb(b0,0wx80) = 0wx80, W8.andb(b0,0wx40) = 0wx40) 77 | val (rsv2, rsv3) = (W8.andb(b0,0wx20) = 0wx20, W8.andb(b0,0w10) = 0wx10) 78 | val opcode = W8.andb(b0,0wxF) 79 | val b1 = w8 sock 80 | val lenf = W8.andb(b1,0wx7F) 81 | val len = case lenf of 82 | 0w126 => w16 sock 83 | | 0w127 => w64 sock 84 | | _ => Compat.w8_to_w64 lenf 85 | val ft = case opcode of 86 | 0wx0 => Cont 87 | | 0wx1 => Text 88 | | 0wx2 => Bin 89 | | 0wx8 => (check len fin; Close) 90 | | 0wx9 => (check len fin; Ping) 91 | | 0wxA => (check len fin; Pong) 92 | | _ => raise Fail ("Unknown opcode: 0x" ^ (Word8.fmt StringCvt.HEX opcode)) 93 | val (mask,masker) = if W8.andb(b1,0wx80)=0wx80 then (bytes sock 4,unmask) 94 | else (emp,fn (_,b) => b) 95 | val payload = unmask (mask,(bytes sock (W64.toInt len))) 96 | in { fin = fin, rsv1 = rsv1, rsv2 = rsv2, rsv3 = rsv3, typ = ft, payload = payload} end 97 | 98 | fun recv sock : Msg = 99 | case (parse sock) of 100 | {typ=Close,payload,...} => CloseMsg (Word32.fromLarge(PackWord16Big.subVec(payload,0))) 101 | | {typ=Ping,...} => PingMsg 102 | | {typ=Pong,...} => PongMsg 103 | | {typ=Text,payload,...} => TextMsg payload 104 | | {typ=Bin,payload,...} => BinMsg payload 105 | | {typ=Cont,payload,...} => ContMsg payload 106 | 107 | fun serve sock (hnd : Msg -> Res) = 108 | let val msg = recv sock 109 | in (case msg of 110 | PongMsg => () 111 | | PingMsg => send sock PongMsg 112 | | (CloseMsg b) => print ("Received close message: code "^(Word32.fmt StringCvt.DEC b)^"\n") 113 | | ContMsg _ => raise Fail "cont frame" 114 | | msg' => 115 | case hnd msg' of 116 | Error err => (print err; print "\n"; Socket.close sock) 117 | | Reply msg => send sock msg 118 | | _ => ()); 119 | serve sock hnd 120 | end 121 | end 122 | -------------------------------------------------------------------------------- /static/html/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | Hello, world! 5 | 6 | 7 |

Echo server

8 |
9 | Your message:
10 | 11 |

12 |

Response:

13 |
14 | 15 | 16 | 17 | -------------------------------------------------------------------------------- /static/js/main.js: -------------------------------------------------------------------------------- 1 | var protocol = location.protocol == 'https:' ? 'wss://' : 'ws://'; 2 | var port = location.port == '' ? '' : (':' + location.port); 3 | var ws = new WebSocket(protocol + location.hostname + port + '/ws'); 4 | ws.onopen = () => { 5 | ws.onmessage = (e) => { 6 | document.getElementById('echo').innerText=e.data; 7 | }; 8 | }; 9 | document.getElementById('message').addEventListener('input', (e) => { 10 | e.stopPropagation(); 11 | e.preventDefault(); 12 | ws.send(document.getElementById('message').value); 13 | }); 14 | --------------------------------------------------------------------------------