├── .dockerignore ├── .gitignore ├── .ocamlformat ├── .travis.yml ├── LICENSE ├── README.md ├── demos ├── send-receive │ ├── .merlin │ ├── build │ ├── config.ml │ ├── run │ ├── test │ └── unikernel.ml ├── sockets │ ├── .merlin │ ├── README.md │ ├── build │ ├── config.ml │ ├── run │ ├── test │ └── unikernel.ml ├── xml-parsing-pkg │ ├── .ocamlformat │ ├── Makefile │ ├── dune-project │ ├── mirage │ │ ├── build-unikernel │ │ ├── config.ml │ │ ├── dune │ │ └── unikernel.ml │ ├── src │ │ ├── dune │ │ ├── xmlparser.ml │ │ └── xmlparser.mli │ ├── test │ │ ├── dune │ │ └── test.ml │ └── xmlparser.opam └── xml-parsing │ ├── Makefile │ ├── scripts │ ├── build │ └── run │ ├── src │ ├── .merlin │ ├── config.ml │ ├── parser.ml │ └── unikernel.ml │ └── test │ ├── .merlin │ ├── dune │ ├── dune-project │ └── test.ml ├── docker ├── ejabberd │ └── ejabberd.yml ├── mirage-xmpp-ci │ ├── Dockerfile │ └── entrypoint.sh ├── mirage-xmpp │ └── Dockerfile ├── prosody │ └── prosody.cfg.lua └── tigase │ └── init.properties ├── dune ├── dune-project ├── makefile ├── mirage-xmpp.opam ├── mirage ├── build-unikernel ├── config.ml ├── dune ├── dune-project └── unikernel.ml ├── pages ├── _config.yml ├── _includes │ └── footer.html ├── _layouts │ └── home.html └── index.md ├── src ├── actions.ml ├── actions.mli ├── connections.ml ├── connections.mli ├── dune ├── events.ml ├── events.mli ├── handler.ml ├── handler.mli ├── jid.ml ├── jid.mli ├── parser.ml ├── parser.mli ├── rosters.ml ├── rosters.mli ├── stanza.ml ├── stanza.mli ├── state.ml ├── state.mli ├── stream.ml ├── stream.mli ├── utils.ml ├── utils.mli ├── xml.ml └── xml.mli └── test ├── integration ├── dune └── integration.ml └── performance ├── dune ├── performance.ml ├── stats.py ├── templates.ml └── templates ├── auth.xml ├── header.xml └── sessions ├── connections.xml ├── general.xml ├── large_roster.xml ├── presence.xml └── roster.xml /.dockerignore: -------------------------------------------------------------------------------- 1 | test/performance/results 2 | demos 3 | _build 4 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | .vscode 3 | 4 | .merlin 5 | *.install 6 | coverage 7 | doc 8 | docs 9 | *.log 10 | 11 | results 12 | 13 | # gh-pages 14 | _site 15 | .sass-cache 16 | 17 | # python stuff 18 | .mypy_cache 19 | 20 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | profile = janestreet -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | 3 | services: 4 | - docker 5 | 6 | script: 7 | - make docker-ci 8 | 9 | deploy: 10 | provider: pages 11 | skip-cleanup: true 12 | github-token: $GITHUB_TOKEN 13 | keep-history: true 14 | local-dir: pages 15 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2018 jeffa5 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # XMPP server on MirageOS 2 | 3 | ## Demos 4 | 5 | The demos folder serves as a reference to some basic necessities for the project. 6 | 7 | Sockets is very simple, basically copied from the mirage website to check building of the unikernel and running locally. 8 | 9 | Send-receive is still simple, basically being an echo server for whatever the user decides to send it. 10 | 11 | xml-parsing is more complex, it handles the connections but also has to include the xml parsing section which is not so simple due to having to push data into a stream where the xml parser pulls it out the other side. 12 | 13 | xml-parsing-pkg is an effort to split the code into a core package which abstracts away from the lower level detail of sending data back and forth. This is the final demo before starting the actual implementation. 14 | -------------------------------------------------------------------------------- /demos/send-receive/.merlin: -------------------------------------------------------------------------------- 1 | PKG lwt mirage mirage-types tcpip mirage-http conduit.mirage mirage-console 2 | PKG cohttp mirage-net-unix mirage-unix mirage-clock-unix functoria 3 | PKG tcpip.ethif tcpip.arpv4 tls logs mirage-logs 4 | PKG magic-mime mirage-types-lwt duration 5 | 6 | S **/ 7 | B **/_build/** -------------------------------------------------------------------------------- /demos/send-receive/build: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | # build 4 | mirage configure -t unix --dhcp false --net direct 5 | 6 | # setup a trap for SIGINT to clean up the directory after building 7 | trap "make clean; exit 0" 2 8 | 9 | # continue building 10 | OPAMVAR_os_family=arch make depend 11 | make -------------------------------------------------------------------------------- /demos/send-receive/config.ml: -------------------------------------------------------------------------------- 1 | open Mirage 2 | 3 | let port = 4 | let doc = 5 | Key.Arg.info ~doc:"The TCP port on which to listen for incoming connections." ["port"] 6 | in 7 | Key.(create "port" Arg.(opt int 8080 doc)) 8 | ;; 9 | 10 | let main = foreign ~keys:[Key.abstract port] "Unikernel.Main" (stackv4 @-> job) 11 | let stack = generic_stackv4 default_network 12 | let () = register "sendrcv" [main $ stack] 13 | -------------------------------------------------------------------------------- /demos/send-receive/run: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | # setup a trap for SIGINT to clean up the directory after building 4 | # trap "make clean; exit 0" 2 5 | 6 | sudo ./sendrcv -l "*:debug" > log 2>&1 7 | -------------------------------------------------------------------------------- /demos/send-receive/test: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | # setup the network tunnel to allow communication 4 | sudo ifconfig tap0 10.0.0.1 up 5 | 6 | # example command to send ping messages to the unikernel (by default gets the 10.0.0.2 address) 7 | ping -c 3 10.0.0.2 8 | 9 | sleep 1 10 | # send some simple data to the unikernel 11 | echo "Hello TCP world!" | nc -nw1 10.0.0.2 8080 12 | 13 | printf "\n\nOpening a netcat connection\n" 14 | # open a netcat session to the server 15 | nc 10.0.0.2 8080 -------------------------------------------------------------------------------- /demos/send-receive/unikernel.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | 3 | module Main (S : Mirage_stack_lwt.V4) = struct 4 | let write_string flow s = 5 | S.TCPV4.write flow s 6 | >>= function 7 | | Ok () -> Lwt.return_unit 8 | | Error e -> 9 | Logs.warn (fun f -> 10 | f "Error occurred from writing to connection: %a" S.TCPV4.pp_write_error e ); 11 | Lwt.return_unit 12 | ;; 13 | 14 | let rec echo flow = 15 | S.TCPV4.read flow 16 | >>= function 17 | | Ok `Eof -> 18 | Logs.info (fun f -> f "Closing connection due to Eof!"); 19 | Lwt.return_unit 20 | | Error e -> 21 | Logs.warn (fun f -> 22 | f "Error reading data from established connection: %a" S.TCPV4.pp_error e ); 23 | Lwt.return_unit 24 | | Ok (`Data b) -> 25 | Logs.debug (fun f -> f "read: %d bytes:\n%s" (Cstruct.len b) (Cstruct.to_string b)); 26 | let reply = Cstruct.of_string ("echo: " ^ Cstruct.to_string b) in 27 | write_string flow reply >>= fun () -> echo flow 28 | ;; 29 | 30 | let on_connect flow = 31 | let dst, dst_port = S.TCPV4.dst flow in 32 | Logs.info (fun f -> 33 | f "new tcp connection from IP %s on port %d" (Ipaddr.V4.to_string dst) dst_port 34 | ); 35 | let welcome = Cstruct.of_string "*\n* Hello from Mirage!\n*\n" in 36 | write_string flow welcome >>= fun () -> echo flow >>= fun () -> S.TCPV4.close flow 37 | ;; 38 | 39 | let start s = 40 | let port = Key_gen.port () in 41 | S.listen_tcpv4 s ~port on_connect; 42 | S.listen s 43 | ;; 44 | end 45 | -------------------------------------------------------------------------------- /demos/sockets/.merlin: -------------------------------------------------------------------------------- 1 | PKG lwt mirage mirage-types tcpip mirage-http conduit.mirage mirage-console 2 | PKG cohttp mirage-net-unix mirage-unix mirage-clock-unix functoria 3 | PKG tcpip.ethif tcpip.arpv4 tls logs mirage-logs 4 | PKG magic-mime mirage-types-lwt duration 5 | 6 | S **/ 7 | B **/_build/** -------------------------------------------------------------------------------- /demos/sockets/README.md: -------------------------------------------------------------------------------- 1 | # Sockets demo 2 | 3 | This demo is largely a copy of the code from the mirage.io website for setting up a connection. 4 | 5 | The `build-and-run` script builds the unikernel, starting it and then waiting for a `SIGINT` (`ctrl-c`) signal before cleaning up the directory. 6 | 7 | The `test` script can be used to simply send data to the unikernel. 8 | -------------------------------------------------------------------------------- /demos/sockets/build: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | # build 4 | mirage configure -t unix --dhcp false --net direct 5 | 6 | # setup a trap for SIGINT to clean up the directory after building 7 | trap "make clean; exit 0" 2 8 | 9 | # continue building 10 | OPAMVAR_os_family=arch make depend 11 | make -------------------------------------------------------------------------------- /demos/sockets/config.ml: -------------------------------------------------------------------------------- 1 | open Mirage 2 | 3 | let port = 4 | let doc = 5 | Key.Arg.info ~doc:"The TCP port on which to listen for incoming connections." ["port"] 6 | in 7 | Key.(create "port" Arg.(opt int 8080 doc)) 8 | ;; 9 | 10 | let main = foreign ~keys:[Key.abstract port] "Unikernel.Main" (stackv4 @-> job) 11 | let stack = generic_stackv4 default_network 12 | let () = register "network" [main $ stack] 13 | -------------------------------------------------------------------------------- /demos/sockets/run: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | # setup a trap for SIGINT to clean up the directory after building 4 | trap "make clean; exit 0" 2 5 | 6 | sudo ./network -l "*:debug" > log 2>&1 -------------------------------------------------------------------------------- /demos/sockets/test: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | # setup the network tunnel to allow communication 4 | sudo ifconfig tap0 10.0.0.1 up 5 | 6 | # example command to send ping messages to the unikernel (by default gets the 10.0.0.2 address) 7 | ping -c 3 10.0.0.2 8 | 9 | sleep 1 10 | # send some simple data to the unikernel 11 | echo "Hello TCP world!" | nc -nw1 10.0.0.2 8080 12 | -------------------------------------------------------------------------------- /demos/sockets/unikernel.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | 3 | module Main (S : Mirage_stack_lwt.V4) = struct 4 | let start s = 5 | let port = Key_gen.port () in 6 | S.listen_tcpv4 s ~port (fun flow -> 7 | let dst, dst_port = S.TCPV4.dst flow in 8 | Logs.info (fun f -> 9 | f 10 | "new tcp connection from IP %s on port %d" 11 | (Ipaddr.V4.to_string dst) 12 | dst_port ); 13 | S.TCPV4.read flow 14 | >>= function 15 | | Ok `Eof -> 16 | Logs.info (fun f -> f "Closing connection!"); 17 | Lwt.return_unit 18 | | Error e -> 19 | Logs.warn (fun f -> 20 | f "Error reading data from established connection: %a" S.TCPV4.pp_error e 21 | ); 22 | Lwt.return_unit 23 | | Ok (`Data b) -> 24 | Logs.debug (fun f -> 25 | f "read: %d bytes:\n%s" (Cstruct.len b) (Cstruct.to_string b) ); 26 | S.TCPV4.close flow ); 27 | S.listen s 28 | ;; 29 | end 30 | -------------------------------------------------------------------------------- /demos/xml-parsing-pkg/.ocamlformat: -------------------------------------------------------------------------------- 1 | profile = janestreet -------------------------------------------------------------------------------- /demos/xml-parsing-pkg/Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: all 2 | all: mirage 3 | 4 | # 5 | # XMLPARSER 6 | # 7 | 8 | # run unit tests for the xmlparser package 9 | .PHONY: unit 10 | unit: clean 11 | dune build @src/runtest 12 | 13 | # build the xmlparser package 14 | .PHONY: build 15 | build: unit 16 | dune build @install 17 | 18 | # install the xmlparser package to opam 19 | .PHONY: install 20 | install: build 21 | dune install 22 | 23 | # 24 | # MIRAGE 25 | # 26 | 27 | # build the mirage unikernel 28 | .PHONY: mirage 29 | mirage: install 30 | dune build @mirage 31 | 32 | # run the integration tests 33 | .PHONY: integration 34 | integration: 35 | # Ensure you are running the unikernel! 36 | sudo ifconfig tap0 10.0.0.1 up 37 | dune build @test/runtest 38 | 39 | # run the unikernel built by mirage 40 | .PHONY: run 41 | run: mirage 42 | cd _build/default/mirage && sudo ./xmlparse -l "*:debug" &> unikernel-log 43 | 44 | # promote the files, typically for expect tests 45 | .PHONY: promote 46 | promote: 47 | dune promote 48 | 49 | # clean the repository 50 | .PHONY: clean 51 | clean: 52 | dune clean 53 | rm -rf coverage 54 | rm -rf doc 55 | 56 | .PHONY: coverage 57 | coverage: clean 58 | rm -rf coverage 59 | BISECT_ENABLE=YES dune build @src/runtest --force 60 | bisect-ppx-report -I _build/default/src -html coverage/ `find . -name 'bisect*.out'` 61 | 62 | .PHONY: doc 63 | doc: clean 64 | rm -rf doc 65 | dune build @doc 66 | cp -r _build/default/_doc/_html doc 67 | 68 | .PHONY: format 69 | format: clean 70 | dune build @{src,mirage,test}/fmt 71 | # --auto-promote -------------------------------------------------------------------------------- /demos/xml-parsing-pkg/dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.4) 2 | (using fmt 1.0) -------------------------------------------------------------------------------- /demos/xml-parsing-pkg/mirage/build-unikernel: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | # build 4 | mirage configure -t unix --dhcp false --net direct 5 | 6 | # continue building 7 | OPAMVAR_os_family=arch make depend 8 | make -------------------------------------------------------------------------------- /demos/xml-parsing-pkg/mirage/config.ml: -------------------------------------------------------------------------------- 1 | open Mirage 2 | 3 | let port = 4 | let doc = 5 | Key.Arg.info ~doc:"The TCP port on which to listen for incoming connections." ["port"] 6 | in 7 | Key.(create "port" Arg.(opt int 8080 doc)) 8 | ;; 9 | 10 | let packages = 11 | [package "markup-lwt"; package "core"; package "lwt_ppx"; package "xmlparser"] 12 | ;; 13 | 14 | let main = foreign ~keys:[Key.abstract port] ~packages "Unikernel.Main" (stackv4 @-> job) 15 | let stack = generic_stackv4 default_network 16 | let () = register "xmlparse" [main $ stack] 17 | -------------------------------------------------------------------------------- /demos/xml-parsing-pkg/mirage/dune: -------------------------------------------------------------------------------- 1 | (alias 2 | (name mirage) 3 | (deps (source_tree .) (package xmlparser)) 4 | (action (system "./build-unikernel"))) -------------------------------------------------------------------------------- /demos/xml-parsing-pkg/mirage/unikernel.ml: -------------------------------------------------------------------------------- 1 | module Main (S : Mirage_stack_lwt.V4) = struct 2 | let write_string flow s = 3 | let s = String.trim s ^ "\n" in 4 | let b = Cstruct.of_string s in 5 | match%lwt S.TCPV4.write flow b with 6 | | Ok () -> Lwt.return_unit 7 | | Error e -> 8 | Logs.warn (fun f -> 9 | f "Error occurred from writing to connection: %a" S.TCPV4.pp_write_error e ); 10 | Lwt.return_unit 11 | ;; 12 | 13 | let write_error_string flow s = 14 | let s = "Error: " ^ String.trim s in 15 | write_string flow s 16 | ;; 17 | 18 | let read flow pushf = 19 | let rec aux () = 20 | match%lwt S.TCPV4.read flow with 21 | | Ok `Eof | Error _ -> Lwt.return_unit 22 | | Ok (`Data b) -> 23 | let s = Cstruct.to_string b in 24 | Logs.info (fun f -> f "Data read from connection: %s" s); 25 | String.iter (fun c -> pushf (Some c)) s; 26 | aux () 27 | in 28 | aux () 29 | ;; 30 | 31 | let on_connect flow = 32 | let stream, pushf = Lwt_stream.create () in 33 | Lwt.async (fun () -> read flow pushf); 34 | let%lwt () = 35 | match%lwt Xmlparser.parse_xml stream with 36 | | Ok (Some s) -> write_string flow s 37 | | Ok None -> Lwt.return_unit 38 | | Error s -> write_error_string flow s 39 | in 40 | Logs.info (fun f -> f "Closing the connection"); 41 | S.TCPV4.close flow 42 | ;; 43 | 44 | let start s = 45 | let port = Key_gen.port () in 46 | S.listen_tcpv4 s ~port on_connect; 47 | S.listen s 48 | ;; 49 | end 50 | -------------------------------------------------------------------------------- /demos/xml-parsing-pkg/src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name xmlparser) 3 | (public_name xmlparser) 4 | (libraries lwt lwt.unix mirage markup-lwt) 5 | (inline_tests (flags -show-counts)) 6 | (preprocess (pps ppx_expect lwt_ppx bisect_ppx -conditional))) -------------------------------------------------------------------------------- /demos/xml-parsing-pkg/src/xmlparser.ml: -------------------------------------------------------------------------------- 1 | exception ParsingError of string 2 | 3 | let make_parser stream = 4 | Markup_lwt.parse_xml 5 | ~report:(fun _ e -> 6 | let error_string = Markup.Error.to_string e in 7 | Logs.warn (fun f -> f "Error occurred during parsing: %s" error_string); 8 | Lwt.fail (ParsingError error_string) ) 9 | stream 10 | ;; 11 | 12 | let pull_signal signals = 13 | let rec aux depth = 14 | match%lwt Markup_lwt.next signals with 15 | | exception ParsingError e -> Lwt.return_error e 16 | | Some signal -> 17 | (match signal with 18 | | `Start_element _ -> 19 | Logs.debug (fun f -> 20 | f "Start element received: %s" (Markup.signal_to_string signal) ); 21 | aux (depth + 1) 22 | | `End_element -> 23 | Logs.debug (fun f -> f "End element received"); 24 | if depth = 1 25 | then ( 26 | Logs.info (fun f -> f "Accepting the parsed XML and notifying user"); 27 | Lwt.return_ok (Some "XML accepted.") ) 28 | else aux (depth - 1) 29 | | `Text _ -> 30 | let signal_string = String.trim (Markup.signal_to_string signal) in 31 | if signal_string <> "" 32 | then Logs.debug (fun f -> f "Text received: %s" signal_string); 33 | aux depth 34 | | _ -> 35 | Logs.debug (fun f -> f "Signal received! %s" (Markup.signal_to_string signal)); 36 | aux depth) 37 | | None -> 38 | Logs.debug (fun f -> f "No signal received, stream empty"); 39 | Lwt.return_ok None 40 | in 41 | aux 0 42 | ;; 43 | 44 | let parse_xml stream = 45 | let signals = Markup_lwt.lwt_stream stream |> make_parser |> Markup.signals in 46 | Logs.info (fun f -> f "Setup parser, beginning to pull signals."); 47 | pull_signal signals 48 | ;; 49 | 50 | (* Set the logging up for the unit tests. Use the default source and formatter and debug to show all logs *) 51 | let setup_logs () = 52 | Logs.set_reporter (Logs_fmt.reporter ()); 53 | Logs.set_level (Some Logs.Debug); 54 | () 55 | ;; 56 | 57 | let parse_string str = 58 | setup_logs (); 59 | let stream = Lwt_stream.of_string str in 60 | let out = 61 | match%lwt parse_xml stream with 62 | | Ok (Some s) -> Lwt.return s 63 | | Ok None -> Lwt.return "" 64 | | Error e -> Lwt.return e 65 | in 66 | let s = Lwt_main.run out in 67 | print_endline s 68 | ;; 69 | 70 | let%expect_test "empty string" = 71 | parse_string ""; 72 | [%expect 73 | {| 74 | run.exe: [INFO] Setup parser, beginning to pull signals. 75 | run.exe: [DEBUG] No signal received, stream empty |}] 76 | ;; 77 | 78 | let%expect_test "no start tag" = 79 | parse_string ""; 80 | [%expect 81 | {| 82 | run.exe: [INFO] Setup parser, beginning to pull signals. 83 | run.exe: [WARNING] Error occurred during parsing: bad document: expected root element 84 | bad document: expected root element |}] 85 | ;; 86 | 87 | let%expect_test "unmatched end tag" = 88 | parse_string ""; 89 | [%expect 90 | {| 91 | run.exe: [INFO] Setup parser, beginning to pull signals. 92 | run.exe: [DEBUG] Start element received: 93 | run.exe: [WARNING] Error occurred during parsing: unmatched end tag 'a' 94 | unmatched end tag 'a' |}] 95 | ;; 96 | 97 | let%expect_test "unmatched start tag" = 98 | parse_string ""; 99 | [%expect 100 | {| 101 | run.exe: [INFO] Setup parser, beginning to pull signals. 102 | run.exe: [DEBUG] Start element received: 103 | run.exe: [DEBUG] Start element received: 104 | run.exe: [WARNING] Error occurred during parsing: unmatched start tag 'a' 105 | unmatched start tag 'a' |}] 106 | ;; 107 | 108 | let%expect_test "simple open close" = 109 | parse_string ""; 110 | [%expect 111 | {| 112 | run.exe: [INFO] Setup parser, beginning to pull signals. 113 | run.exe: [DEBUG] Start element received: 114 | run.exe: [DEBUG] End element received 115 | run.exe: [INFO] Accepting the parsed XML and notifying user 116 | XML accepted. |}] 117 | ;; 118 | 119 | let%expect_test "no closing tag" = 120 | parse_string "No closing tag!"; 121 | [%expect 122 | {| 123 | run.exe: [INFO] Setup parser, beginning to pull signals. 124 | run.exe: [DEBUG] Start element received: 125 | run.exe: [DEBUG] Start element received: 126 | run.exe: [DEBUG] Text received: No closing tag! 127 | run.exe: [WARNING] Error occurred during parsing: unmatched start tag 'body' 128 | unmatched start tag 'body' |}] 129 | ;; 130 | 131 | let%expect_test "xmpp initial" = 132 | parse_string 133 | "\n\ 140 | \ \n\ 141 | \ foo\n\ 142 | \ \n\ 143 | \ "; 144 | [%expect 145 | {| 146 | run.exe: [INFO] Setup parser, beginning to pull signals. 147 | run.exe: [DEBUG] Start element received: 148 | run.exe: [DEBUG] Start element received: 149 | run.exe: [DEBUG] Start element received: 150 | run.exe: [DEBUG] Text received: foo 151 | run.exe: [DEBUG] End element received 152 | run.exe: [DEBUG] End element received 153 | run.exe: [DEBUG] End element received 154 | run.exe: [INFO] Accepting the parsed XML and notifying user 155 | XML accepted. |}] 156 | ;; 157 | 158 | let%expect_test "unknown namespace" = 159 | parse_string 160 | "\n\ 161 | \ \n\ 163 | \ \n\ 164 | \ "; 165 | [%expect 166 | {| 167 | run.exe: [INFO] Setup parser, beginning to pull signals. 168 | run.exe: [WARNING] Error occurred during parsing: unknown namespace 'stream' 169 | unknown namespace 'stream' |}] 170 | ;; 171 | 172 | let%expect_test "xmpp initial extended" = 173 | parse_string 174 | "\n\ 175 | \ \n\ 183 | \ \n\ 184 | \ \n\ 186 | \ \n\ 187 | \ "; 188 | [%expect 189 | {| 190 | run.exe: [INFO] Setup parser, beginning to pull signals. 191 | run.exe: [DEBUG] Signal received! ?> 192 | run.exe: [DEBUG] Start element received: 193 | run.exe: [DEBUG] Start element received: 194 | run.exe: [DEBUG] Start element received: 195 | run.exe: [DEBUG] End element received 196 | run.exe: [DEBUG] End element received 197 | run.exe: [DEBUG] End element received 198 | run.exe: [INFO] Accepting the parsed XML and notifying user 199 | XML accepted. |}] 200 | ;; 201 | -------------------------------------------------------------------------------- /demos/xml-parsing-pkg/src/xmlparser.mli: -------------------------------------------------------------------------------- 1 | (** A module to handle parsing of given xml streams. Generates error messages to enforce strict xml and does not do error recovery. *) 2 | 3 | (** [parse_xml s] will make an xml parser from the given stream and repeatedly consume characters from it. It will return a wrapped result of text to send back to the user or an error message *) 4 | val parse_xml : char Lwt_stream.t -> (string option, string) Result.result Lwt.t 5 | -------------------------------------------------------------------------------- /demos/xml-parsing-pkg/test/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name test) 3 | (libraries lwt lwt.unix) 4 | (inline_tests (flags -show-counts)) 5 | (preprocess (pps ppx_expect lwt_ppx))) -------------------------------------------------------------------------------- /demos/xml-parsing-pkg/test/test.ml: -------------------------------------------------------------------------------- 1 | exception Timeout 2 | 3 | let send ?(timeout = 5.) ?(host = "10.0.0.2") ?(port = 8080) str = 4 | let timeout_t = 5 | let%lwt () = Lwt_unix.sleep timeout in 6 | Lwt.fail Timeout 7 | in 8 | let request = 9 | let addr = Unix.ADDR_INET (Unix.inet_addr_of_string host, port) in 10 | Lwt_io.( 11 | with_connection addr (fun (i, o) -> 12 | let%lwt () = write o str in 13 | read i )) 14 | in 15 | let s = Lwt_main.run (Lwt.pick [request; timeout_t]) in 16 | print_endline s 17 | ;; 18 | 19 | let%expect_test "no start tag" = 20 | send ""; 21 | [%expect {| Error: bad document: expected root element |}] 22 | ;; 23 | 24 | let%expect_test "unmatched end tag" = 25 | send ""; 26 | [%expect {| Error: unmatched end tag 'a' |}] 27 | ;; 28 | 29 | let%expect_test "unmatched start tag" = 30 | send ""; 31 | [%expect {| Error: unmatched start tag 'a' |}] 32 | ;; 33 | 34 | let%expect_test "simple open close" = 35 | send ""; 36 | [%expect {| XML accepted. |}] 37 | ;; 38 | 39 | let%expect_test "no closing tag" = 40 | send "No closing tag!"; 41 | [%expect {| Error: unmatched start tag 'body' |}] 42 | ;; 43 | 44 | let%expect_test "xmpp initial" = 45 | send 46 | "\n\ 53 | \ \n\ 54 | \ foo\n\ 55 | \ \n\ 56 | \ "; 57 | [%expect {| XML accepted. |}] 58 | ;; 59 | 60 | let%expect_test "unknown namespace" = 61 | send 62 | "\n\ 63 | \ \n\ 65 | \ \n\ 66 | \ "; 67 | [%expect {| Error: unknown namespace 'stream' |}] 68 | ;; 69 | 70 | let%expect_test "xmpp initial extended" = 71 | send 72 | "\n\ 73 | \ \n\ 81 | \ \n\ 82 | \ \n\ 84 | \ \n\ 85 | \ "; 86 | [%expect {| XML accepted. |}] 87 | ;; 88 | -------------------------------------------------------------------------------- /demos/xml-parsing-pkg/xmlparser.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "xmlparser" 3 | version: "dev" 4 | synopsis: "XML parser for XMPP" 5 | maintainer: "Andrew J " 6 | authors: "Andrew J" 7 | license: "MIT" 8 | homepage: "https://github.com/jeffa5/mirage-xmpp" 9 | bug-reports: "https://github.com/jeffa5/mirage-xmpp/issues" 10 | depends: [ "ocaml" "ocamlfind" ] 11 | build: ["dune" "build" "-p" name "-j" jobs] -------------------------------------------------------------------------------- /demos/xml-parsing/Makefile: -------------------------------------------------------------------------------- 1 | BUILDDIR = _build 2 | SCRIPTSDIR = scripts 3 | SRCDIR = src 4 | 5 | .PHONY: all build run test promote clean 6 | all: build run 7 | 8 | build: clean 9 | mkdir -p $(BUILDDIR) 10 | cp $(SCRIPTSDIR)/* $(BUILDDIR) 11 | cp $(SRCDIR)/* $(BUILDDIR) 12 | cd $(BUILDDIR) && ./build 13 | 14 | run: 15 | cd $(BUILDDIR) && ./run 16 | 17 | test: 18 | # Ensure you are running the unikernel! 19 | sudo ifconfig tap0 10.0.0.1 up 20 | dune runtest 21 | 22 | promote: 23 | dune promote 24 | 25 | clean: 26 | rm -rf $(BUILDDIR) -------------------------------------------------------------------------------- /demos/xml-parsing/scripts/build: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | # build 4 | mirage configure -t unix --dhcp false --net direct 5 | 6 | # continue building 7 | OPAMVAR_os_family=arch make depend 8 | make -------------------------------------------------------------------------------- /demos/xml-parsing/scripts/run: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | sudo ./xmlparse -l "*:debug" > unikernel-log 2>&1 -------------------------------------------------------------------------------- /demos/xml-parsing/src/.merlin: -------------------------------------------------------------------------------- 1 | PKG lwt mirage mirage-types tcpip mirage-http conduit.mirage mirage-console 2 | PKG cohttp mirage-net-unix mirage-unix mirage-clock-unix functoria 3 | PKG tcpip.ethif tcpip.arpv4 tls logs mirage-logs 4 | PKG magic-mime mirage-types-lwt duration 5 | PKG markup markup-lwt 6 | PKG core 7 | PKG lwt_ppx 8 | 9 | S ** -------------------------------------------------------------------------------- /demos/xml-parsing/src/config.ml: -------------------------------------------------------------------------------- 1 | open Mirage 2 | 3 | let port = 4 | let doc = 5 | Key.Arg.info ~doc:"The TCP port on which to listen for incoming connections." ["port"] 6 | in 7 | Key.(create "port" Arg.(opt int 8080 doc)) 8 | ;; 9 | 10 | let packages = [package "markup-lwt"; package "core"; package "lwt_ppx"] 11 | let main = foreign ~keys:[Key.abstract port] ~packages "Unikernel.Main" (stackv4 @-> job) 12 | let stack = generic_stackv4 default_network 13 | let () = register "xmlparse" [main $ stack] 14 | -------------------------------------------------------------------------------- /demos/xml-parsing/src/parser.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | 3 | exception ParsingError of string 4 | 5 | let make_parser stream = 6 | Markup_lwt.parse_xml 7 | ~report:(fun _ e -> 8 | let error_string = Markup.Error.to_string e in 9 | Logs.warn (fun f -> f "Error occurred during parsing: %s" error_string); 10 | Lwt.fail (ParsingError error_string) ) 11 | stream 12 | ;; 13 | 14 | let pull_signal signals = 15 | let rec aux depth = 16 | match%lwt Markup_lwt.next signals with 17 | | exception ParsingError e -> Lwt.return_error e 18 | | Some signal -> 19 | (match signal with 20 | | `Start_element _ -> 21 | Logs.debug (fun f -> 22 | f "Start element received: %s" (Markup.signal_to_string signal) ); 23 | aux (depth + 1) 24 | | `End_element -> 25 | Logs.debug (fun f -> f "End element received"); 26 | if depth = 1 27 | then ( 28 | Logs.info (fun f -> f "Accepting the parsed XML and notifying user"); 29 | Lwt.return_ok (Some "XML accepted.") ) 30 | else aux (depth - 1) 31 | | `Text _ -> 32 | let signal_string = String.strip (Markup.signal_to_string signal) in 33 | if signal_string <> "" 34 | then Logs.debug (fun f -> f "Text received: %s" signal_string); 35 | aux depth 36 | | _ -> 37 | Logs.debug (fun f -> f "Signal received! %s" (Markup.signal_to_string signal)); 38 | aux depth) 39 | | None -> 40 | Logs.debug (fun f -> f "None signal received"); 41 | Lwt.return_ok None 42 | in 43 | aux 0 44 | ;; 45 | 46 | let parse_xml stream = 47 | let signals = Markup_lwt.lwt_stream stream |> make_parser |> Markup.signals in 48 | Logs.info (fun f -> f "Setup parser, beginning to pull signals."); 49 | pull_signal signals 50 | ;; 51 | -------------------------------------------------------------------------------- /demos/xml-parsing/src/unikernel.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | 3 | module Main (S : Mirage_stack_lwt.V4) = struct 4 | let write_string flow s = 5 | let s = String.strip s ^ "\n" in 6 | let b = Cstruct.of_string s in 7 | match%lwt S.TCPV4.write flow b with 8 | | Ok () -> Lwt.return_unit 9 | | Error e -> 10 | Logs.warn (fun f -> 11 | f "Error occurred from writing to connection: %a" S.TCPV4.pp_write_error e ); 12 | Lwt.return_unit 13 | ;; 14 | 15 | let write_error_string flow s = 16 | let s = "Error: " ^ String.strip s in 17 | write_string flow s 18 | ;; 19 | 20 | let read flow pushf = 21 | let rec aux () = 22 | match%lwt S.TCPV4.read flow with 23 | | Ok `Eof | Error _ -> Lwt.return_unit 24 | | Ok (`Data b) -> 25 | let s = Cstruct.to_string b in 26 | Logs.info (fun f -> f "Data read from connection: %s" s); 27 | String.iter ~f:(fun c -> pushf (Some c)) s; 28 | aux () 29 | in 30 | aux () 31 | ;; 32 | 33 | let on_connect flow = 34 | let stream, pushf = Lwt_stream.create () in 35 | Lwt.async (fun () -> read flow pushf); 36 | let%lwt () = 37 | match%lwt Parser.parse_xml stream with 38 | | Ok (Some s) -> write_string flow s 39 | | Ok None -> Lwt.return_unit 40 | | Error s -> write_error_string flow s 41 | in 42 | Logs.info (fun f -> f "Closing the connection"); 43 | S.TCPV4.close flow 44 | ;; 45 | 46 | let start s = 47 | let port = Key_gen.port () in 48 | S.listen_tcpv4 s ~port on_connect; 49 | S.listen s 50 | ;; 51 | end 52 | -------------------------------------------------------------------------------- /demos/xml-parsing/test/.merlin: -------------------------------------------------------------------------------- 1 | B /home/andrew/.opam/4.05.0/lib/base 2 | B /home/andrew/.opam/4.05.0/lib/base/caml 3 | B /home/andrew/.opam/4.05.0/lib/base/md5 4 | B /home/andrew/.opam/4.05.0/lib/base/shadow_stdlib 5 | B /home/andrew/.opam/4.05.0/lib/bin_prot 6 | B /home/andrew/.opam/4.05.0/lib/bin_prot/shape 7 | B /home/andrew/.opam/4.05.0/lib/bytes 8 | B /home/andrew/.opam/4.05.0/lib/core_kernel 9 | B /home/andrew/.opam/4.05.0/lib/core_kernel/base_for_tests 10 | B /home/andrew/.opam/4.05.0/lib/fieldslib 11 | B /home/andrew/.opam/4.05.0/lib/jane-street-headers 12 | B /home/andrew/.opam/4.05.0/lib/lwt 13 | B /home/andrew/.opam/4.05.0/lib/ocaml 14 | B /home/andrew/.opam/4.05.0/lib/parsexp 15 | B /home/andrew/.opam/4.05.0/lib/ppx_assert/runtime-lib 16 | B /home/andrew/.opam/4.05.0/lib/ppx_bench/runtime-lib 17 | B /home/andrew/.opam/4.05.0/lib/ppx_compare/runtime-lib 18 | B /home/andrew/.opam/4.05.0/lib/ppx_expect/collector 19 | B /home/andrew/.opam/4.05.0/lib/ppx_expect/common 20 | B /home/andrew/.opam/4.05.0/lib/ppx_expect/config 21 | B /home/andrew/.opam/4.05.0/lib/ppx_hash/runtime-lib 22 | B /home/andrew/.opam/4.05.0/lib/ppx_inline_test/config 23 | B /home/andrew/.opam/4.05.0/lib/ppx_inline_test/runtime-lib 24 | B /home/andrew/.opam/4.05.0/lib/ppx_sexp_conv/runtime-lib 25 | B /home/andrew/.opam/4.05.0/lib/result 26 | B /home/andrew/.opam/4.05.0/lib/sexplib 27 | B /home/andrew/.opam/4.05.0/lib/sexplib0 28 | B /home/andrew/.opam/4.05.0/lib/splittable_random 29 | B /home/andrew/.opam/4.05.0/lib/stdio 30 | B /home/andrew/.opam/4.05.0/lib/typerep 31 | B /home/andrew/.opam/4.05.0/lib/variantslib 32 | B ../_build/default/test/.test.objs 33 | S /home/andrew/.opam/4.05.0/lib/base 34 | S /home/andrew/.opam/4.05.0/lib/base/caml 35 | S /home/andrew/.opam/4.05.0/lib/base/md5 36 | S /home/andrew/.opam/4.05.0/lib/base/shadow_stdlib 37 | S /home/andrew/.opam/4.05.0/lib/bin_prot 38 | S /home/andrew/.opam/4.05.0/lib/bin_prot/shape 39 | S /home/andrew/.opam/4.05.0/lib/bytes 40 | S /home/andrew/.opam/4.05.0/lib/core_kernel 41 | S /home/andrew/.opam/4.05.0/lib/core_kernel/base_for_tests 42 | S /home/andrew/.opam/4.05.0/lib/fieldslib 43 | S /home/andrew/.opam/4.05.0/lib/jane-street-headers 44 | S /home/andrew/.opam/4.05.0/lib/lwt 45 | S /home/andrew/.opam/4.05.0/lib/ocaml 46 | S /home/andrew/.opam/4.05.0/lib/parsexp 47 | S /home/andrew/.opam/4.05.0/lib/ppx_assert/runtime-lib 48 | S /home/andrew/.opam/4.05.0/lib/ppx_bench/runtime-lib 49 | S /home/andrew/.opam/4.05.0/lib/ppx_compare/runtime-lib 50 | S /home/andrew/.opam/4.05.0/lib/ppx_expect/collector 51 | S /home/andrew/.opam/4.05.0/lib/ppx_expect/common 52 | S /home/andrew/.opam/4.05.0/lib/ppx_expect/config 53 | S /home/andrew/.opam/4.05.0/lib/ppx_hash/runtime-lib 54 | S /home/andrew/.opam/4.05.0/lib/ppx_inline_test/config 55 | S /home/andrew/.opam/4.05.0/lib/ppx_inline_test/runtime-lib 56 | S /home/andrew/.opam/4.05.0/lib/ppx_sexp_conv/runtime-lib 57 | S /home/andrew/.opam/4.05.0/lib/result 58 | S /home/andrew/.opam/4.05.0/lib/sexplib 59 | S /home/andrew/.opam/4.05.0/lib/sexplib0 60 | S /home/andrew/.opam/4.05.0/lib/splittable_random 61 | S /home/andrew/.opam/4.05.0/lib/stdio 62 | S /home/andrew/.opam/4.05.0/lib/typerep 63 | S /home/andrew/.opam/4.05.0/lib/variantslib 64 | S . 65 | FLG -ppx '/home/andrew/Documents/cambridge/computer-science/part-ii/project/mirage-xmpp/demos/xml-parsing/_build/default/.ppx/lwt_ppx+ppx_expect/ppx.exe --as-ppx --cookie '\''library-name="test"'\''' 66 | FLG -w @a-4-29-40-41-42-44-45-48-58-59-60-40 -strict-sequence -strict-formats -short-paths -keep-locs 67 | -------------------------------------------------------------------------------- /demos/xml-parsing/test/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name test) 3 | (libraries core_kernel lwt lwt.unix) 4 | (inline_tests) 5 | (preprocess (pps ppx_expect lwt_ppx))) -------------------------------------------------------------------------------- /demos/xml-parsing/test/dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.4) 2 | (using fmt 1.0) -------------------------------------------------------------------------------- /demos/xml-parsing/test/test.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | 3 | exception Timeout 4 | 5 | let send ?(timeout = 5.) ?(host = "10.0.0.2") ?(port = 8080) str = 6 | let timeout_t = 7 | let%lwt () = Lwt_unix.sleep timeout in 8 | Lwt.fail Timeout 9 | in 10 | let request = 11 | let addr = Unix.ADDR_INET (Unix.inet_addr_of_string host, port) in 12 | Lwt_io.( 13 | with_connection addr (fun (i, o) -> 14 | let%lwt () = write o str in 15 | read i )) 16 | in 17 | let s = Lwt_main.run (Lwt.pick [request; timeout_t]) in 18 | printf "%s" s 19 | ;; 20 | 21 | let%expect_test "no start tag" = 22 | send ""; 23 | [%expect {| Error: bad document: expected root element |}] 24 | ;; 25 | 26 | let%expect_test "unmatched end tag" = 27 | send ""; 28 | [%expect {| Error: unmatched end tag 'a' |}] 29 | ;; 30 | 31 | let%expect_test "unmatched start tag" = 32 | send ""; 33 | [%expect {| Error: unmatched start tag 'a' |}] 34 | ;; 35 | 36 | let%expect_test "simple open close" = 37 | send ""; 38 | [%expect {| XML accepted. |}] 39 | ;; 40 | 41 | let%expect_test "no closing tag" = 42 | send "No closing tag!"; 43 | [%expect {| Error: unmatched start tag 'body' |}] 44 | ;; 45 | 46 | let%expect_test "xmpp initial" = 47 | send 48 | "\n\ 55 | \ \n\ 56 | \ foo\n\ 57 | \ \n\ 58 | \ "; 59 | [%expect {| XML accepted. |}] 60 | ;; 61 | 62 | let%expect_test "unknown namespace" = 63 | send 64 | "\n\ 65 | \ \n\ 67 | \ \n\ 68 | \ "; 69 | [%expect {| Error: unknown namespace 'stream' |}] 70 | ;; 71 | 72 | let%expect_test "xmpp initial extended" = 73 | send 74 | "\n\ 75 | \ \n\ 83 | \ \n\ 84 | \ \n\ 86 | \ \n\ 87 | \ "; 88 | [%expect {| XML accepted. |}] 89 | ;; 90 | -------------------------------------------------------------------------------- /docker/ejabberd/ejabberd.yml: -------------------------------------------------------------------------------- 1 | listen: 2 | - port: 5222 3 | module: ejabberd_c2s 4 | starttls_required: false 5 | auth_method: [anonymous] 6 | anonymous_protocol: sasl_anon 7 | modules: 8 | mod_roster: 9 | versioning: false 10 | use_cache: true 11 | -------------------------------------------------------------------------------- /docker/mirage-xmpp-ci/Dockerfile: -------------------------------------------------------------------------------- 1 | FROM ocaml/opam2 2 | 3 | WORKDIR /home/opam/app 4 | 5 | COPY . . 6 | 7 | RUN sudo chown -R opam:opam . 8 | -------------------------------------------------------------------------------- /docker/mirage-xmpp-ci/entrypoint.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -e 4 | 5 | echo -e "travis_fold:start:opam_setup" 6 | opam switch 4.05 7 | eval $(opam env) 8 | opam repository set-url default https://opam.ocaml.org 9 | opam update 10 | opam upgrade -y 11 | 12 | eval $(opam env) 13 | 14 | opam pin add . --no-action 15 | opam depext --yes --update --install mirage-xmpp 16 | opam depext --yes --update --install mirage 17 | echo -e "travis_fold:end:opam_setup" 18 | 19 | echo -e "travis_fold:start:unit" 20 | make unit 21 | echo -e "travis_fold:end:unit" 22 | 23 | echo -e "travis_fold:start:integration" 24 | make integration 25 | echo -e "travis_fold:end:integration" 26 | 27 | echo -e "travis_fold:start:makedocs" 28 | opam install --yes odoc 29 | make doc 30 | echo -e "travis_fold:end:makedocs" 31 | 32 | echo -e "travis_fold:start:coverage" 33 | make coverage 34 | echo -e "travis_fold:end:coverage" 35 | -------------------------------------------------------------------------------- /docker/mirage-xmpp/Dockerfile: -------------------------------------------------------------------------------- 1 | FROM ocaml/opam2 2 | 3 | WORKDIR /home/opam/app 4 | 5 | COPY . . 6 | 7 | RUN sudo chown -R opam:opam . 8 | 9 | RUN opam switch 4.05 \ 10 | && eval $(opam env) \ 11 | && opam repository set-url default https://opam.ocaml.org \ 12 | && opam update \ 13 | && opam upgrade -y \ 14 | && opam pin add . --no-action \ 15 | && opam depext --yes --update --install mirage-xmpp \ 16 | && opam depext --yes --update --install mirage \ 17 | && make mirage 18 | 19 | EXPOSE 5222 20 | 21 | CMD mirage/xmpp --hostname="localhost" -l "info" 2>&1 22 | -------------------------------------------------------------------------------- /docker/prosody/prosody.cfg.lua: -------------------------------------------------------------------------------- 1 | -- Prosody Example Configuration File 2 | -- 3 | -- If it wasn't already obvious, -- starts a comment, and all 4 | -- text after it on a line is ignored by Prosody. 5 | -- 6 | -- The config is split into sections, a global section, and one 7 | -- for each defined host that we serve. You can add as many host 8 | -- sections as you like. 9 | -- 10 | -- Lists are written 11 | -- _ = { "like", "this", "one" } 12 | -- Lists can also be of { 1, 2, 3 } numbers, etc. 13 | -- Either commas, or semi-colons; may be used 14 | -- as seperators. 15 | -- 16 | -- A table is a list of values, except each value has a name. An 17 | -- example would be: 18 | -- 19 | -- examlpe_ssl = { key = "keyfile.key", certificate = "certificate.crt" } 20 | -- 21 | -- Whitespace (that is tabs, spaces, line breaks) is mostly insignificant, so 22 | -- can 23 | -- be placed anywhere 24 | -- that you deem fitting. 25 | -- 26 | -- Tip: You can check that the syntax of this file is correct 27 | -- when you have finished by running this command: 28 | -- prosodyctl check config 29 | -- If there are any errors, it will let you know what and where 30 | -- they are, otherwise it will keep quiet. 31 | -- 32 | -- The only thing left to do is rename this file to remove the .dist ending, and fill in the 33 | -- blanks. Good luck, and happy Jabbering! 34 | 35 | 36 | ---------- Server-wide settings ---------- 37 | -- Settings in this section apply to the whole server and are the default settings 38 | -- for any virtual hosts 39 | 40 | -- This is a (by default, empty) list of accounts that are admins 41 | -- for the server. Note that you must create the accounts separately 42 | -- (see https://prosody.im/doc/creating_accounts for info) 43 | -- Example: admins = { "user1@example.com", "user2@example.net" } 44 | admins = { } 45 | 46 | -- Enable use of libevent for better performance under high load 47 | -- For more information see: https://prosody.im/doc/libevent 48 | --use_libevent = true 49 | 50 | -- Prosody will always look in its source directory for modules, but 51 | -- this option allows you to specify additional locations where Prosody 52 | -- will look for modules first. For community modules, see https://modules.prosody.im/ 53 | --plugin_paths = {} 54 | 55 | -- This is the list of modules Prosody will load on startup. 56 | -- It looks for mod_modulename.lua in the plugins folder, so make sure that exists too. 57 | -- Documentation for bundled modules can be found at: https://prosody.im/doc/modules 58 | modules_enabled = { 59 | 60 | -- Generally required 61 | "roster"; -- Allow users to have a roster. Recommended ;) 62 | "saslauth"; -- Authentication for clients and servers. Recommended if you want to log in. 63 | -- "tls"; -- Add support for secure TLS on c2s/s2s connections 64 | -- "dialback"; -- s2s dialback support 65 | -- "disco"; -- Service discovery 66 | 67 | -- Not essential, but recommended 68 | -- "carbons"; -- Keep multiple clients in sync 69 | -- "pep"; -- Enables users to publish their mood, activity, playing music and more 70 | -- "private"; -- Private XML storage (for room bookmarks, etc.) 71 | -- "blocklist"; -- Allow users to block communications with other users 72 | -- "vcard"; -- Allow users to set vCards 73 | 74 | -- Nice to have 75 | -- "version"; -- Replies to server version requests 76 | -- "uptime"; -- Report how long server has been running 77 | -- "time"; -- Let others know the time here on this server 78 | -- "ping"; -- Replies to XMPP pings with pongs 79 | -- "register"; -- Allow users to register on this server using a client and change passwords 80 | --"mam"; -- Store messages in an archive and allow users to access it 81 | 82 | -- Admin interfaces 83 | -- "admin_adhoc"; -- Allows administration via an XMPP client that supports ad-hoc commands 84 | --"admin_telnet"; -- Opens telnet console interface on localhost port 5582 85 | 86 | -- HTTP modules 87 | --"bosh"; -- Enable BOSH clients, aka "Jabber over HTTP" 88 | --"websocket"; -- XMPP over WebSockets 89 | --"http_files"; -- Serve static files from a directory over HTTP 90 | 91 | -- Other specific functionality 92 | --"limits"; -- Enable bandwidth limiting for XMPP connections 93 | --"groups"; -- Shared roster support 94 | --"server_contact_info"; -- Publish contact information for this service 95 | --"announce"; -- Send announcement to all online users 96 | --"welcome"; -- Welcome users who register accounts 97 | --"watchregistrations"; -- Alert admins of registrations 98 | --"motd"; -- Send a message to users when they log in 99 | --"legacyauth"; -- Legacy authentication. Only used by some old clients and bots. 100 | --"proxy65"; -- Enables a file transfer proxy service which clients behind NAT can use 101 | } 102 | 103 | -- These modules are auto-loaded, but should you want 104 | -- to disable them then uncomment them here: 105 | modules_disabled = { 106 | "offline"; -- Store offline messages 107 | -- "c2s"; -- Handle client connections 108 | "s2s"; -- Handle server-to-server connections 109 | -- "posix"; -- POSIX functionality, sends server to background, enables syslog, etc. 110 | } 111 | 112 | -- Disable account creation by default, for security 113 | -- For more information see https://prosody.im/doc/creating_accounts 114 | allow_registration = false 115 | 116 | -- Force clients to use encrypted connections? This option will 117 | -- prevent clients from authenticating unless they are using encryption. 118 | 119 | c2s_require_encryption = false 120 | 121 | -- Force servers to use encrypted connections? This option will 122 | -- prevent servers from authenticating unless they are using encryption. 123 | -- Note that this is different from authentication 124 | 125 | s2s_require_encryption = true 126 | 127 | 128 | -- Force certificate authentication for server-to-server connections? 129 | -- This provides ideal security, but requires servers you communicate 130 | -- with to support encryption AND present valid, trusted certificates. 131 | -- NOTE: Your version of LuaSec must support certificate verification! 132 | -- For more information see https://prosody.im/doc/s2s#security 133 | 134 | s2s_secure_auth = false 135 | 136 | -- Some servers have invalid or self-signed certificates. You can list 137 | -- remote domains here that will not be required to authenticate using 138 | -- certificates. They will be authenticated using DNS instead, even 139 | -- when s2s_secure_auth is enabled. 140 | 141 | --s2s_insecure_domains = { "insecure.example" } 142 | 143 | -- Even if you leave s2s_secure_auth disabled, you can still require valid 144 | -- certificates for some domains by specifying a list here. 145 | 146 | --s2s_secure_domains = { "jabber.org" } 147 | 148 | -- Select the authentication backend to use. The 'internal' providers 149 | -- use Prosody's configured data storage to store the authentication data. 150 | -- To allow Prosody to offer secure authentication mechanisms to clients, the 151 | -- default provider stores passwords in plaintext. If you do not trust your 152 | -- server please see https://prosody.im/doc/modules/mod_auth_internal_hashed 153 | -- for information about using the hashed backend. 154 | 155 | authentication = "anonymous" 156 | 157 | -- Select the storage backend to use. By default Prosody uses flat files 158 | -- in its configured data directory, but it also supports more backends 159 | -- through modules. An "sql" backend is included by default, but requires 160 | -- additional dependencies. See https://prosody.im/doc/storage for more info. 161 | 162 | --storage = "sql" -- Default is "internal" 163 | 164 | -- For the "sql" backend, you can uncomment *one* of the below to configure: 165 | --sql = { driver = "SQLite3", database = "prosody.sqlite" } -- Default. 'database' is the filename. 166 | --sql = { driver = "MySQL", database = "prosody", username = "prosody", password = "secret", host = "localhost" } 167 | --sql = { driver = "PostgreSQL", database = "prosody", username = "prosody", password = "secret", host = "localhost" } 168 | 169 | 170 | -- Archiving configuration 171 | -- If mod_mam is enabled, Prosody will store a copy of every message. This 172 | -- is used to synchronize conversations between multiple clients, even if 173 | -- they are offline. This setting controls how long Prosody will keep 174 | -- messages in the archive before removing them. 175 | 176 | archive_expires_after = "1w" -- Remove archived messages after 1 week 177 | 178 | -- You can also configure messages to be stored in-memory only. For more 179 | -- archiving options, see https://prosody.im/doc/modules/mod_mam 180 | 181 | daemonize = false 182 | -- Logging configuration 183 | -- For advanced logging see https://prosody.im/doc/logging 184 | log = { 185 | info = "prosody.log"; -- Change 'info' to 'debug' for verbose logging 186 | error = "prosody.err"; 187 | -- "*syslog"; -- Uncomment this for logging to syslog 188 | "*console"; -- Log to the console, useful for debugging with daemonize=false 189 | } 190 | 191 | -- Uncomment to enable statistics 192 | -- For more info see https://prosody.im/doc/statistics 193 | -- statistics = "internal" 194 | 195 | -- Certificates 196 | -- Every virtual host and component needs a certificate so that clients and 197 | -- servers can securely verify its identity. Prosody will automatically load 198 | -- certificates/keys from the directory specified here. 199 | -- For more information, including how to use 'prosodyctl' to auto-import certificates 200 | -- (from e.g. Let's Encrypt) see https://prosody.im/doc/certificates 201 | 202 | -- Location of directory to find certificates in (relative to main config file): 203 | -- certificates = "certs" 204 | 205 | ----------- Virtual hosts ----------- 206 | -- You need to add a VirtualHost entry for each domain you wish Prosody to serve. 207 | -- Settings under each VirtualHost entry apply *only* to that host. 208 | 209 | VirtualHost "localhost" 210 | 211 | --VirtualHost "example.com" 212 | -- certificate = "/path/to/example.crt" 213 | 214 | ------ Components ------ 215 | -- You can specify components to add hosts that provide special services, 216 | -- like multi-user conferences, and transports. 217 | -- For more information on components, see https://prosody.im/doc/components 218 | 219 | ---Set up a MUC (multi-user chat) room server on conference.example.com: 220 | --Component "conference.example.com" "muc" 221 | 222 | ---Set up an external component (default component port is 5347) 223 | -- 224 | -- External components allow adding various services, such as gateways/ 225 | -- transports to other networks like ICQ, MSN and Yahoo. For more info 226 | -- see: https://prosody.im/doc/components#adding_an_external_component 227 | -- 228 | --Component "gateway.example.com" 229 | -- component_secret = "password" 230 | -------------------------------------------------------------------------------- /docker/tigase/init.properties: -------------------------------------------------------------------------------- 1 | --virt-hosts=localhost 2 | -------------------------------------------------------------------------------- /dune: -------------------------------------------------------------------------------- 1 | (data_only_dirs demos pages) 2 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.7) 2 | (using fmt 1.1) 3 | -------------------------------------------------------------------------------- /makefile: -------------------------------------------------------------------------------- 1 | .PHONY: all 2 | all: mirage 3 | 4 | # run unit tests 5 | .PHONY: unit 6 | unit: clean 7 | dune build @src/runtest 8 | 9 | # build the 10 | .PHONY: build 11 | build: unit 12 | dune build @install 13 | 14 | # install to opam 15 | .PHONY: install 16 | install: build 17 | dune install 18 | opam pin -y . 19 | 20 | # build the mirage unikernel 21 | .PHONY: mirage 22 | mirage: install 23 | dune build @mirage 24 | cp _build/default/mirage/xmpp mirage 25 | 26 | # run the integration tests 27 | .PHONY: integration 28 | integration: mirage 29 | dune build @test/integration/runtest 30 | 31 | # run the unikernel built by mirage 32 | .PHONY: run 33 | run: mirage 34 | mirage/xmpp --hostname="mirage-xmpp.dev" -l "debug" 2>&1 | tee unikernel.log 35 | 36 | # promote the files, typically for expect tests 37 | .PHONY: promote 38 | promote: 39 | dune promote 40 | 41 | # clean the repository 42 | .PHONY: clean 43 | clean: 44 | dune clean 45 | 46 | # ensure the pages directory is available 47 | .PHONY: pages 48 | pages: 49 | mkdir -p pages 50 | 51 | # build the coverage report 52 | .PHONY: coverage 53 | coverage: clean pages 54 | rm -rf pages/coverage 55 | BISECT_ENABLE=YES dune build @runtest --force 56 | bisect-ppx-report -I _build/default/src -html pages/coverage `find . -name 'bisect*.out'` 57 | 58 | # build the docs 59 | .PHONY: doc 60 | doc: clean pages 61 | rm -rf pages/docs 62 | dune build @doc 63 | cp -r _build/default/_doc/_html pages/docs 64 | 65 | # format the files 66 | .PHONY: format 67 | format: clean 68 | dune build @fmt --auto-promote 69 | 70 | # run a dune @check to generate merlin files 71 | .PHONY: check 72 | check: 73 | dune build @check 74 | 75 | .PHONY: docker-build 76 | docker-build: 77 | @echo -en "travis_fold:start:docker-build\r" 78 | docker build -f docker/mirage-xmpp-ci/Dockerfile -t jeffas/mirage-xmpp-ci:latest . 79 | @echo -en "travis_fold:end:docker-build\r" 80 | 81 | .PHONY: docker-ci 82 | docker-ci: docker-build 83 | docker container prune -f 84 | @echo -en "travis_fold:start:docker-run\r" 85 | docker run --name mirage-xmpp-ci jeffas/mirage-xmpp-ci:latest docker/mirage-xmpp-ci/entrypoint.sh 86 | @echo -en "travis_fold:end:docker-run\r" 87 | @echo -en "travis_fold:start:docker-copy\r" 88 | docker cp mirage-xmpp-ci:/home/opam/app/pages/docs pages 89 | docker cp mirage-xmpp-ci:/home/opam/app/pages/coverage pages 90 | @echo -en "travis_fold:end:docker-copy\r" 91 | 92 | .PHONY: docker-prune 93 | docker-prune: 94 | docker system prune 95 | 96 | .PHONY: docker-xmpp 97 | docker-xmpp: 98 | docker build -f docker/mirage-xmpp/Dockerfile -t jeffas/mirage-xmpp . 99 | 100 | .PHONY: performance 101 | performance: 102 | dune build test/performance/performance.exe 103 | cp _build/default/test/performance/performance.exe test/performance/performance 104 | -------------------------------------------------------------------------------- /mirage-xmpp.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "mirage-xmpp" 3 | version: "dev" 4 | synopsis: "XMPP implementation for Ocaml" 5 | maintainer: "Andrew J " 6 | authors: "Andrew J" 7 | license: "MIT" 8 | homepage: "https://github.com/jeffa5/mirage-xmpp" 9 | bug-reports: "https://github.com/jeffa5/mirage-xmpp/issues" 10 | depends: [ 11 | "ocaml" {>= "4.03.0"} 12 | "dune" {build} 13 | "lwt" 14 | "sexplib" 15 | "markup-lwt" 16 | "ppx_expect" 17 | "ppx_deriving" 18 | "lwt_ppx" 19 | "bisect_ppx" 20 | "astring" 21 | "asetmap" 22 | "uuidm" 23 | "base64" {>= "3.0.0"} 24 | ] 25 | build: [ 26 | ["dune" "build" "-p" name "-j" jobs] 27 | ] 28 | run-test: [ 29 | ["dune" "build" "@src/runtest"] 30 | ] 31 | -------------------------------------------------------------------------------- /mirage/build-unikernel: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | # build 4 | mirage configure -t unix --net socket 5 | 6 | # continue building 7 | if [ -z ${TRAVIS_BUILD} ]; then 8 | OPAMVAR_os_family=arch make depend 9 | else 10 | make depend 11 | fi 12 | make 13 | -------------------------------------------------------------------------------- /mirage/config.ml: -------------------------------------------------------------------------------- 1 | open Mirage 2 | 3 | let port = 4 | let doc = 5 | Key.Arg.info ~doc:"The TCP port on which to listen for incoming connections." ["port"] 6 | in 7 | Key.(create "port" Arg.(opt int 5222 doc)) 8 | ;; 9 | 10 | let hostname = 11 | let doc = Key.Arg.info ~doc:"The hostname for the server." ["hostname"] in 12 | Key.(create "hostname" Arg.(opt string "localhost" doc)) 13 | ;; 14 | 15 | let packages = [package "lwt_ppx"; package "mirage-xmpp"] 16 | 17 | let main = 18 | foreign 19 | ~keys:[Key.abstract port; Key.abstract hostname] 20 | ~packages 21 | "Unikernel.Main" 22 | (stackv4 @-> job) 23 | ;; 24 | 25 | let stack = generic_stackv4 default_network 26 | let () = register "xmpp" [main $ stack] 27 | -------------------------------------------------------------------------------- /mirage/dune: -------------------------------------------------------------------------------- 1 | (alias 2 | (name mirage) 3 | (deps (source_tree .) (package mirage-xmpp)) 4 | (action (system "./build-unikernel"))) 5 | -------------------------------------------------------------------------------- /mirage/dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.6) 2 | -------------------------------------------------------------------------------- /mirage/unikernel.ml: -------------------------------------------------------------------------------- 1 | module Main (S : Mirage_stack_lwt.V4) = struct 2 | let write_string flow s = 3 | let s = String.trim s ^ "\n" in 4 | let b = Cstruct.of_string s in 5 | match%lwt S.TCPV4.write flow b with 6 | | Ok () -> Lwt.return_unit 7 | | Error e -> 8 | Logs.warn (fun f -> 9 | f "Error occurred from writing to connection: %a" S.TCPV4.pp_write_error e ); 10 | Lwt.return_unit 11 | ;; 12 | 13 | let read flow pushf = 14 | let dst, dst_port = S.TCPV4.dst flow in 15 | let dst = Ipaddr.V4.to_string dst in 16 | let rec aux () = 17 | match%lwt S.TCPV4.read flow with 18 | | Ok `Eof | Error _ -> Lwt.return_unit 19 | | Ok (`Data b) -> 20 | let s = Cstruct.to_string b in 21 | Logs.debug (fun f -> f "Read <- %s:%d : %s" dst dst_port s); 22 | String.iter (fun c -> pushf (Some c)) s; 23 | aux () 24 | in 25 | aux () 26 | ;; 27 | 28 | let mvar = Lwt_mvar.create_empty () 29 | 30 | let write flow out_stream = 31 | let dst, dst_port = S.TCPV4.dst flow in 32 | let dst = Ipaddr.V4.to_string dst in 33 | let rec aux () = 34 | match%lwt Lwt_stream.get out_stream with 35 | | Some s -> 36 | Logs.debug (fun f -> f "Send -> %s:%d : %s" dst dst_port s); 37 | let%lwt () = write_string flow s in 38 | aux () 39 | | None -> 40 | let%lwt () = Lwt_mvar.put mvar true in 41 | Lwt.return_unit 42 | in 43 | aux () 44 | ;; 45 | 46 | let on_connect hostname flow = 47 | let dst, dst_port = S.TCPV4.dst flow in 48 | Logs.info (fun f -> 49 | f "New tcp connection from IP %s on port %d" (Ipaddr.V4.to_string dst) dst_port 50 | ); 51 | let instream, infun = Lwt_stream.create () in 52 | Lwt.async (fun () -> read flow infun); 53 | let outstream, outfun = Lwt_stream.create () in 54 | Lwt.async (fun () -> write flow outstream); 55 | let handler = 56 | Mirage_xmpp.Handler.create ~stream:instream ~callback:outfun ~hostname 57 | in 58 | let%lwt () = Mirage_xmpp.Handler.handle handler in 59 | let%lwt _ = Lwt_mvar.take mvar in 60 | Logs.info (fun f -> 61 | f 62 | "Closing tcp connection from IP %s on port %d" 63 | (Ipaddr.V4.to_string dst) 64 | dst_port ); 65 | S.TCPV4.close flow 66 | ;; 67 | 68 | let start stack = 69 | Logs.info (fun f -> f "Started Unikernel"); 70 | let port = Key_gen.port () in 71 | let hostname = Key_gen.hostname () in 72 | Logs.info (fun f -> f "Port is: %d" port); 73 | Logs.info (fun f -> f "Hostname is: %s" hostname); 74 | S.listen_tcpv4 stack ~port (on_connect hostname); 75 | S.listen_tcpv4 stack ~port:8081 (fun _flow -> 76 | Logs.info (fun f -> f "Received exit signal"); 77 | exit 0 ); 78 | Logs.info (fun f -> f "Started listening"); 79 | S.listen stack 80 | ;; 81 | end 82 | -------------------------------------------------------------------------------- /pages/_config.yml: -------------------------------------------------------------------------------- 1 | # Welcome to Jekyll! 2 | # 3 | # This config file is meant for settings that affect your whole blog, values 4 | # which you are expected to set up once and rarely edit after that. If you find 5 | # yourself editing this file very often, consider using Jekyll's data files 6 | # feature for the data you need to update frequently. 7 | # 8 | # For technical reasons, this file is *NOT* reloaded automatically when you use 9 | # 'bundle exec jekyll serve'. If you change this file, please restart the server process. 10 | 11 | # Site settings 12 | # These are used to personalize your new site. If you look in the HTML files, 13 | # you will see them accessed via {{ site.title }}, {{ site.email }}, and so on. 14 | # You can create any custom variable you would like, and they will be accessible 15 | # in the templates via {{ site.myvariable }}. 16 | title: Jeffas | Mirage XMPP 17 | description: >- # this means to ignore newlines until "baseurl:" 18 | XMPP server implementation in OCaml for MirageOS 19 | baseurl: "/mirage-xmpp" # the subpath of your site, e.g. /blog 20 | url: "" # the base hostname & protocol for your site, e.g. http://example.com 21 | github_username: Jeffa5 22 | 23 | permalink: pretty 24 | 25 | # Build settings 26 | markdown: kramdown 27 | theme: minima 28 | 29 | # Exclude from processing. 30 | # The following items will not be processed, by default. Create a custom list 31 | # to override the default setting. 32 | # exclude: 33 | # - Gemfile 34 | # - Gemfile.lock 35 | # - node_modules 36 | # - vendor/bundle/ 37 | # - vendor/cache/ 38 | # - vendor/gems/ 39 | # - vendor/ruby/ 40 | -------------------------------------------------------------------------------- /pages/_includes/footer.html: -------------------------------------------------------------------------------- 1 |
2 | 3 | 4 |
5 | 6 |

{{ site.title | escape }}

7 | 8 |
9 | 10 |
11 | {%- include social.html -%} 12 |
13 | 14 |
15 |

{{- site.description | escape -}}

16 |
17 |
18 | 19 |
20 | 21 |
22 | -------------------------------------------------------------------------------- /pages/_layouts/home.html: -------------------------------------------------------------------------------- 1 | --- 2 | layout: default 3 | --- 4 | 5 |
6 | {%- if page.title -%} 7 |

{{ page.title }}

8 | {%- endif -%} 9 | 10 | {{ content }} 11 | 12 |
-------------------------------------------------------------------------------- /pages/index.md: -------------------------------------------------------------------------------- 1 | --- 2 | layout: home 3 | title: Links 4 | --- 5 | 6 | # Check out the [docs!](docs) 7 | 8 | # And don't forget the [coverage!](coverage) 9 | -------------------------------------------------------------------------------- /src/actions.ml: -------------------------------------------------------------------------------- 1 | open Sexplib.Std 2 | 3 | type handler_actions = 4 | | RESET_PARSER 5 | | EXIT 6 | [@@deriving sexp] 7 | 8 | type error_type = 9 | | Auth 10 | | Cancel 11 | | Continue 12 | | Modify 13 | | Wait 14 | [@@deriving sexp] 15 | 16 | type t = 17 | | SEND_STREAM_HEADER 18 | | SEND_STREAM_FEATURES_SASL 19 | | SEND_SASL_SUCCESS 20 | | SEND_STREAM_FEATURES 21 | | SESSION_START_SUCCESS of string 22 | | CLOSE 23 | | ERROR of string 24 | | SET_USER of string 25 | | SET_USER_ANON 26 | | SET_JID_RESOURCE of {id : string; resource : string option} 27 | | GET_ROSTER of string 28 | | SET_ROSTER of 29 | { id : string 30 | ; target : Jid.Bare.t 31 | ; handle : string 32 | ; groups : string list } 33 | | PUSH_ROSTER of {ato : Jid.t option; contact : Jid.t} 34 | | ADD_TO_CONNECTIONS 35 | | REMOVE_FROM_CONNECTIONS 36 | | SUBSCRIPTION_REQUEST of {ato : Jid.t; xml : Xml.t; from : Jid.t option} 37 | | UPDATE_PRESENCE of {status : Rosters.Presence.t; xml : Xml.t option} 38 | | SEND_PRESENCE_UPDATE of {from : Jid.t; xml : Xml.t option} 39 | | SEND_CURRENT_PRESENCE of Jid.t 40 | | IQ_ERROR of {error_type : error_type; error_tag : string; id : string} 41 | | MESSAGE of {ato : Jid.t; message : Xml.t} 42 | | ROSTER_REMOVE of {id : string; target : Jid.t} 43 | | SUBSCRIPTION_APPROVAL of {ato : Jid.t; xml : Xml.t; from : Jid.t option} 44 | | ROSTER_SET_FROM of Jid.t 45 | | PROBE_PRESENCE 46 | | SUBSCRIPTION_CANCELLATION of {user : Jid.t; force : bool} 47 | | SUBSCRIPTION_REMOVAL of {contact : Jid.t} 48 | | SEND_DATA of string 49 | [@@deriving sexp] 50 | 51 | let error_type_to_string = function 52 | | Auth -> "auth" 53 | | Cancel -> "cancel" 54 | | Continue -> "continue" 55 | | Modify -> "modify" 56 | | Wait -> "wait" 57 | ;; 58 | 59 | let to_string t = Sexplib.Sexp.to_string_hum @@ sexp_of_t t 60 | -------------------------------------------------------------------------------- /src/actions.mli: -------------------------------------------------------------------------------- 1 | (** The module for actions generated by the state machine *) 2 | 3 | type handler_actions = 4 | | RESET_PARSER 5 | | EXIT 6 | [@@deriving sexp] 7 | 8 | type error_type = 9 | | Auth 10 | | Cancel 11 | | Continue 12 | | Modify 13 | | Wait 14 | [@@deriving sexp] 15 | 16 | val error_type_to_string : error_type -> string 17 | 18 | (** The type of actions, examples for now *) 19 | type t = 20 | | SEND_STREAM_HEADER 21 | | SEND_STREAM_FEATURES_SASL 22 | | SEND_SASL_SUCCESS 23 | | SEND_STREAM_FEATURES 24 | | SESSION_START_SUCCESS of string 25 | | CLOSE 26 | | ERROR of string 27 | | SET_USER of string 28 | | SET_USER_ANON 29 | | SET_JID_RESOURCE of {id : string; resource : string option} 30 | | GET_ROSTER of string 31 | | SET_ROSTER of 32 | { id : string 33 | ; target : Jid.Bare.t 34 | ; handle : string 35 | ; groups : string list } 36 | | PUSH_ROSTER of {ato : Jid.t option; contact : Jid.t} 37 | | ADD_TO_CONNECTIONS 38 | | REMOVE_FROM_CONNECTIONS 39 | | SUBSCRIPTION_REQUEST of {ato : Jid.t; xml : Xml.t; from : Jid.t option} 40 | | UPDATE_PRESENCE of {status : Rosters.Presence.t; xml : Xml.t option} 41 | | SEND_PRESENCE_UPDATE of {from : Jid.t; xml : Xml.t option} 42 | | SEND_CURRENT_PRESENCE of Jid.t 43 | | IQ_ERROR of {error_type : error_type; error_tag : string; id : string} 44 | | MESSAGE of {ato : Jid.t; message : Xml.t} 45 | | ROSTER_REMOVE of {id : string; target : Jid.t} 46 | | SUBSCRIPTION_APPROVAL of {ato : Jid.t; xml : Xml.t; from : Jid.t option} 47 | | ROSTER_SET_FROM of Jid.t 48 | | PROBE_PRESENCE 49 | | SUBSCRIPTION_CANCELLATION of {user : Jid.t; force : bool} 50 | | SUBSCRIPTION_REMOVAL of {contact : Jid.t} 51 | | SEND_DATA of string 52 | [@@deriving sexp] 53 | 54 | (** [to_string t] takes an action and returns its string representation *) 55 | val to_string : t -> string 56 | -------------------------------------------------------------------------------- /src/connections.ml: -------------------------------------------------------------------------------- 1 | open Asetmap 2 | module Jid_map = Map.Make (Jid.Full) 3 | 4 | let mutex = Lwt_mutex.create () 5 | let with_mutex f = Lwt_mutex.with_lock mutex f 6 | let t = ref Jid_map.empty 7 | 8 | let add jid (f : Actions.t option -> unit) = 9 | with_mutex (fun () -> 10 | t := Jid_map.add jid f !t; 11 | Lwt.return_unit ) 12 | ;; 13 | 14 | let find jid = with_mutex (fun () -> Jid_map.find jid !t |> Lwt.return) 15 | 16 | let find_all bare_jid = 17 | with_mutex (fun () -> 18 | Jid_map.filter (fun fjid _ -> bare_jid = Jid.Full.to_bare fjid) !t 19 | |> Jid_map.to_list 20 | |> Lwt.return ) 21 | ;; 22 | 23 | let remove jid = 24 | with_mutex (fun () -> 25 | t := Jid_map.remove jid !t; 26 | Lwt.return_unit ) 27 | ;; 28 | 29 | let clear () = 30 | with_mutex (fun () -> 31 | t := Jid_map.empty; 32 | Lwt.return_unit ) 33 | ;; 34 | 35 | let to_string () = 36 | with_mutex (fun () -> 37 | Jid_map.to_list !t 38 | |> Sexplib.Conv.sexp_of_list (fun jid_push -> 39 | Sexplib.Conv.sexp_of_pair 40 | Jid.Full.sexp_of_t 41 | Sexplib.Conv.sexp_of_fun 42 | jid_push ) 43 | |> Sexplib.Sexp.to_string_hum 44 | |> Lwt.return ) 45 | ;; 46 | 47 | let test_connections actions = 48 | let test = 49 | let%lwt () = clear () in 50 | let%lwt _ = actions () in 51 | let%lwt s = to_string () in 52 | let%lwt () = Lwt_io.printl s in 53 | Lwt_io.flush_all () 54 | in 55 | Lwt_main.run test 56 | ;; 57 | 58 | let%expect_test "empty initially" = 59 | test_connections (fun () -> Lwt.return_unit); 60 | [%expect {| () |}] 61 | ;; 62 | 63 | let%expect_test "add one connection" = 64 | ( test_connections 65 | @@ fun () -> add (Jid.Full.of_string "juliet@im.example.com/balcony") (fun _ -> ()) ); 66 | [%expect {| ((((juliet im.example.com) balcony) )) |}] 67 | ;; 68 | 69 | let%expect_test "add two connection" = 70 | ( test_connections 71 | @@ fun () -> 72 | let%lwt () = add (Jid.Full.of_string "juliet@im.example.com/balcony") (fun _ -> ()) in 73 | add (Jid.Full.of_string "romeo@home.elsewhere.com/ground") (fun _ -> ()) ); 74 | [%expect 75 | {| 76 | ((((juliet im.example.com) balcony) ) 77 | (((romeo home.elsewhere.com) ground) )) |}] 78 | ;; 79 | 80 | let%expect_test "find all matches bare jid" = 81 | ( test_connections 82 | @@ fun () -> 83 | let%lwt () = add (Jid.Full.of_string "juliet@im.example.com/balcony") (fun _ -> ()) in 84 | let%lwt connected_resources = find_all (Jid.Bare.of_string "juliet@im.example.com") in 85 | Lwt_list.iter_s 86 | (fun (target_jid, _) -> Lwt_io.printl (Jid.Full.to_string target_jid)) 87 | connected_resources ); 88 | [%expect 89 | {| 90 | juliet@im.example.com/balcony 91 | ((((juliet im.example.com) balcony) )) |}] 92 | ;; 93 | -------------------------------------------------------------------------------- /src/connections.mli: -------------------------------------------------------------------------------- 1 | (** Need to store active connections in order to be able to send data to them from other users *) 2 | 3 | (** [add t j f] adds [j] and [f] to [t] and returns a new [t] with them added. [f] is the push function to the stream for that user *) 4 | val add : Jid.Full.t -> (Actions.t option -> unit) -> unit Lwt.t 5 | 6 | (** [find t j] returns the push function associated with the [j] in the connections map if it is present *) 7 | val find : Jid.Full.t -> (Actions.t option -> unit) option Lwt.t 8 | 9 | (** [find_all j] returns the list of jid * actions_push function pairs which correspond to the same bare jid as [j] *) 10 | val find_all : Jid.Bare.t -> (Jid.Full.t * (Actions.t option -> unit)) list Lwt.t 11 | 12 | (** [remove t j] removes the jid [j] entry from the table if present *) 13 | val remove : Jid.Full.t -> unit Lwt.t 14 | 15 | val to_string : unit -> string Lwt.t 16 | val clear : unit -> unit Lwt.t 17 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name mirage_xmpp) 3 | (public_name mirage-xmpp) 4 | (libraries lwt lwt.unix markup-lwt astring asetmap uuidm base64 sexplib) 5 | (inline_tests 6 | (flags -show-counts -strict)) 7 | (preprocess 8 | (pps ppx_expect lwt_ppx ppx_deriving.std ppx_sexp_conv bisect_ppx 9 | -conditional))) 10 | -------------------------------------------------------------------------------- /src/events.ml: -------------------------------------------------------------------------------- 1 | open Astring 2 | open Sexplib.Std 3 | 4 | type t = 5 | | STREAM_HEADER of {version : string} 6 | | SASL_AUTH of {user : string; password : string} 7 | | ANONYMOUS_SASL_AUTH 8 | | RESOURCE_BIND_SERVER_GEN of {id : string} 9 | | RESOURCE_BIND_CLIENT_GEN of {id : string; resource : string} 10 | | SESSION_START of string 11 | | STREAM_CLOSE 12 | | ERROR of string 13 | | ROSTER_GET of string 14 | | ROSTER_SET of {id : string; target : Jid.t; handle : string; groups : string list} 15 | | ROSTER_REMOVE of {id : string; target : Jid.t} 16 | | PRESENCE_UPDATE of {status : Rosters.Presence.t; xml : Xml.t option} 17 | | IQ_ERROR of {error_type : Actions.error_type; error_tag : string; id : string} 18 | | MESSAGE of {ato : Jid.t; message : Xml.t} 19 | | LOG_OUT 20 | | NOOP 21 | | SUBSCRIPTION_REQUEST of {ato : Jid.t; xml : Xml.t} 22 | | SUBSCRIPTION_APPROVAL of {ato : Jid.t; xml : Xml.t} 23 | | SUBSCRIPTION_CANCELLATION of {user : Jid.t} 24 | | SUBSCRIPTION_REMOVAL of {contact : Jid.t} 25 | [@@deriving sexp] 26 | 27 | let to_string t = Sexplib.Sexp.to_string_hum @@ sexp_of_t t 28 | let not_implemented = ERROR "not implemented" 29 | 30 | let lift_iq = function 31 | | Xml.Element (((_prefix, _name), attributes), children) -> 32 | (match Stanza.get_type attributes with 33 | | Some "set" -> 34 | (match children with 35 | | [Xml.Element (((_p, "bind"), _attrs), [])] -> 36 | (* resource bind with server-generated resource identifier (7.6) *) 37 | RESOURCE_BIND_SERVER_GEN {id = Stanza.get_id_exn attributes} 38 | | [Xml.Element (((_p, "bind"), _attrs), [child])] -> 39 | (match child with 40 | | Xml.Element (((_, "resource"), []), [Xml.Text resource]) -> 41 | RESOURCE_BIND_CLIENT_GEN {id = Stanza.get_id_exn attributes; resource} 42 | | _ -> ERROR "Unexpected child of resource bind") 43 | | [ Xml.Element 44 | ( ((_, "query"), [(_, Xml.Xmlns "jabber:iq:roster")]) 45 | , [Xml.Element (((_, "item"), attrs), group_elements)] ) ] -> 46 | (match Stanza.get_subscription attrs with 47 | | Some "remove" -> 48 | ROSTER_REMOVE {id = Stanza.get_id_exn attributes; target = Stanza.get_jid attrs} 49 | | _ -> 50 | let groups = 51 | List.map 52 | (fun element -> 53 | match element with 54 | | Xml.Element (((_, "group"), _), [Xml.Text group]) -> group 55 | | _ -> assert false ) 56 | group_elements 57 | in 58 | let jid = Stanza.get_jid attrs in 59 | let handle = 60 | match Stanza.get_name attrs with Some name -> name | None -> "" 61 | in 62 | ROSTER_SET {id = Stanza.get_id_exn attributes; target = jid; handle; groups}) 63 | | [Xml.Element (((_, "query"), [(_, Xml.Xmlns "jabber:iq:register")]), _)] -> 64 | let id = Stanza.get_id_exn attributes in 65 | IQ_ERROR {error_type = Actions.Cancel; error_tag = "feature-not-implemented"; id} 66 | | [Xml.Element (((_, "session"), _), [])] -> 67 | SESSION_START (Stanza.get_id_exn attributes) 68 | | _ -> 69 | ERROR 70 | ( "No children matched for iq of type set\n" 71 | ^ String.concat ~sep:"\nnext xml: " 72 | @@ List.map 73 | (function 74 | | Xml.Element _ as element -> "Element: " ^ Xml.to_string element 75 | | Xml.Text _ as text -> "Text: " ^ Xml.to_string text) 76 | children )) 77 | | Some "get" -> 78 | (match children with 79 | | [Xml.Element (((_, "query"), [(_, Xml.Xmlns "jabber:iq:roster")]), _)] -> 80 | (* roster get query *) 81 | ROSTER_GET (Stanza.get_id_exn attributes) 82 | | _ -> 83 | let id = Stanza.get_id_exn attributes in 84 | IQ_ERROR {error_type = Actions.Cancel; error_tag = "feature-not-implemented"; id}) 85 | | Some "result" -> NOOP 86 | | _ -> ERROR "Type of iq expected to be 'set' or 'get'") 87 | | Xml.Text _t -> ERROR "Expected an iq stanza, not text" 88 | ;; 89 | 90 | let lift_presence = function 91 | | Xml.Element (((namespace, name), attributes), children) -> 92 | (match Stanza.get_type attributes with 93 | | Some "subscribe" -> 94 | let rec modify_to = function 95 | | [] -> [] 96 | | (ns, Xml.To jid) :: attrs -> (ns, Xml.To (Jid.to_bare jid)) :: attrs 97 | | a :: attrs -> a :: modify_to attrs 98 | in 99 | let ato = Stanza.get_to attributes |> Jid.to_bare in 100 | SUBSCRIPTION_REQUEST 101 | {ato; xml = Xml.Element (((namespace, name), modify_to attributes), children)} 102 | | Some "subscribed" -> 103 | let rec modify_to = function 104 | | [] -> [] 105 | | (ns, Xml.To jid) :: attrs -> (ns, Xml.To (Jid.to_bare jid)) :: attrs 106 | | a :: attrs -> a :: modify_to attrs 107 | in 108 | let ato = Stanza.get_to attributes |> Jid.to_bare in 109 | SUBSCRIPTION_APPROVAL 110 | {ato; xml = Xml.Element (((namespace, name), modify_to attributes), children)} 111 | | Some "unavailable" -> 112 | PRESENCE_UPDATE 113 | { status = Offline 114 | ; xml = Some (Xml.Element (((namespace, name), attributes), children)) } 115 | | Some "unsubscribed" -> 116 | SUBSCRIPTION_CANCELLATION {user = Stanza.get_to attributes |> Jid.to_bare} 117 | | Some "unsubscribe" -> 118 | SUBSCRIPTION_REMOVAL {contact = Stanza.get_to attributes |> Jid.to_bare} 119 | | None -> 120 | PRESENCE_UPDATE 121 | { status = Online 122 | ; xml = Some (Xml.Element (((namespace, name), attributes), children)) } 123 | | _ -> not_implemented) 124 | | Xml.Text _t -> ERROR "Expected a presence stanza, not text" 125 | ;; 126 | 127 | let lift_message = function 128 | | Xml.Element (((_prefix, _name), attributes), _children) as message -> 129 | let ato = Stanza.get_to attributes in 130 | let message = Xml.remove_prefixes message in 131 | MESSAGE {ato; message} 132 | | Xml.Text _t -> ERROR "Expected a message stanza, not text" 133 | ;; 134 | 135 | let lift parse_result = 136 | let open Parser in 137 | match parse_result with 138 | | Stanza stanza -> 139 | (match stanza with 140 | | Stanza.Iq element -> lift_iq element 141 | | Stanza.Presence element -> lift_presence element 142 | | Stanza.Message element -> lift_message element) 143 | | Sasl_auth xml -> 144 | let rec get_mechanism = function 145 | | [] -> raise Not_found 146 | | (_, Xml.Mechanism mechanism) :: _ -> mechanism 147 | | _ :: attrs -> get_mechanism attrs 148 | in 149 | let invalid_mechanism () = 150 | ERROR 151 | ( Xml.to_string 152 | @@ Xml.create 153 | ~children:[Xml.create (("", "invalid-mechanism"), [])] 154 | (("", "failure"), ["", Xml.Xmlns "urn:ietf:params:xml:ns:xmpp-sasl"]) ) 155 | in 156 | (match xml with 157 | | Element ((_name, attributes), [Text b64_string]) -> 158 | if get_mechanism attributes = "PLAIN" 159 | then 160 | match Base64.decode b64_string with 161 | | Ok decoded_string -> 162 | (match String.cut ~sep:"\000" (String.trim decoded_string) with 163 | | Some (_userdom, userpass) -> 164 | (match String.cut ~sep:"\000" userpass with 165 | | Some (user, pass) -> SASL_AUTH {user; password = pass} 166 | | None -> ERROR "SASL: couldn't find second 0 byte") 167 | | _ -> ERROR "SASL: couldn't find first 0 byte") 168 | | Error e -> (match e with `Msg e -> ERROR e) 169 | else invalid_mechanism () 170 | | Element ((_, attributes), []) -> 171 | if get_mechanism attributes = "ANONYMOUS" 172 | then ANONYMOUS_SASL_AUTH 173 | else invalid_mechanism () 174 | | _ -> invalid_mechanism ()) 175 | | Stream_Element stream_element -> 176 | (match stream_element with 177 | | Header (_name, attributes) -> 178 | let version = Stanza.get_version attributes in 179 | STREAM_HEADER {version} 180 | | Features -> not_implemented 181 | | Error -> ERROR "Stream level error" 182 | | Close -> STREAM_CLOSE) 183 | | Error e -> ERROR e 184 | ;; 185 | 186 | let%expect_test "lift error gives error" = 187 | let event = lift (Error "some error") in 188 | print_endline (to_string event); 189 | [%expect {| (ERROR "some error") |}] 190 | ;; 191 | 192 | let%expect_test "iq get" = 193 | let event = 194 | lift 195 | (Stanza 196 | (Stanza.Iq 197 | (Element 198 | ( ( ("", "iq") 199 | , [ "", Xml.From (Jid.of_string "juliet@capulet.com/balcony") 200 | ; "", Xml.Id "h83vxa4c" 201 | ; "", Xml.Type "get" ] ) 202 | , [Xml.Element ((("", "query"), ["", Xml.Xmlns "jabber:iq:roster"]), [])] 203 | )))) 204 | in 205 | print_endline (to_string event); 206 | [%expect {| (ROSTER_GET h83vxa4c) |}] 207 | ;; 208 | 209 | let%expect_test "iq set" = 210 | let event = 211 | lift 212 | (Stanza 213 | (Stanza.Iq 214 | (Element 215 | ( (("", "iq"), ["", Xml.Id "l3b1vs75"; "", Xml.Type "set"]) 216 | , [Xml.Element ((("", "bind"), []), [])] )))) 217 | in 218 | print_endline (to_string event); 219 | [%expect {| (RESOURCE_BIND_SERVER_GEN (id l3b1vs75)) |}] 220 | ;; 221 | 222 | let%expect_test "roster get" = 223 | let event = 224 | lift 225 | (Stanza 226 | (Stanza.Iq 227 | (Element 228 | ( ( ("", "iq") 229 | , [ "", Xml.From (Jid.of_string "juliet@example.com/balony") 230 | ; "", Xml.Id "bv1bs71f" 231 | ; "", Xml.Type "get" ] ) 232 | , [Xml.Element ((("", "query"), ["", Xml.Xmlns "jabber:iq:roster"]), [])] 233 | )))) 234 | in 235 | print_endline (to_string event); 236 | [%expect {| (ROSTER_GET bv1bs71f) |}] 237 | ;; 238 | 239 | let%expect_test "roster set" = 240 | let event = 241 | lift 242 | (Stanza 243 | (Stanza.Iq 244 | (Element 245 | ( ( ("", "iq") 246 | , [ "", Xml.From (Jid.of_string "juliet@example.com/balony") 247 | ; "", Xml.Id "rs1" 248 | ; "", Xml.Type "set" ] ) 249 | , [ Xml.Element 250 | ( (("", "query"), ["", Xml.Xmlns "jabber:iq:roster"]) 251 | , [ Xml.Element 252 | ( ( ("", "item") 253 | , [ "", Xml.Jid (Jid.of_string "nurse@example.com") 254 | ; "", Xml.Name "Nurse" ] ) 255 | , [] ) ] ) ] )))) 256 | in 257 | print_endline (to_string event); 258 | [%expect 259 | {| 260 | (ROSTER_SET (id rs1) (target (Bare_JID (nurse example.com))) (handle Nurse) 261 | (groups ())) |}] 262 | ;; 263 | -------------------------------------------------------------------------------- /src/events.mli: -------------------------------------------------------------------------------- 1 | (** The module to handle conversion of stanzas into events for the state machine *) 2 | 3 | (** The type of events, examples for now *) 4 | type t = 5 | | STREAM_HEADER of {version : string} 6 | | SASL_AUTH of {user : string; password : string} 7 | | ANONYMOUS_SASL_AUTH 8 | | RESOURCE_BIND_SERVER_GEN of {id : string} 9 | | RESOURCE_BIND_CLIENT_GEN of {id : string; resource : string} 10 | | SESSION_START of string 11 | | STREAM_CLOSE 12 | | ERROR of string 13 | | ROSTER_GET of string 14 | | ROSTER_SET of {id : string; target : Jid.t; handle : string; groups : string list} 15 | | ROSTER_REMOVE of {id : string; target : Jid.t} 16 | | PRESENCE_UPDATE of {status : Rosters.Presence.t; xml : Xml.t option} 17 | | IQ_ERROR of {error_type : Actions.error_type; error_tag : string; id : string} 18 | | MESSAGE of {ato : Jid.t; message : Xml.t} 19 | | LOG_OUT 20 | | NOOP 21 | | SUBSCRIPTION_REQUEST of {ato : Jid.t; xml : Xml.t} 22 | | SUBSCRIPTION_APPROVAL of {ato : Jid.t; xml : Xml.t} 23 | | SUBSCRIPTION_CANCELLATION of {user : Jid.t} 24 | | SUBSCRIPTION_REMOVAL of {contact : Jid.t} 25 | [@@deriving sexp] 26 | 27 | (** [to_string t] takes an event and returns it's string representation *) 28 | val to_string : t -> string 29 | 30 | (** [lift pr] converts the parse_result [pr] into an event type suitable for sending to the state machine *) 31 | val lift : Parser.parse_result -> t 32 | -------------------------------------------------------------------------------- /src/handler.mli: -------------------------------------------------------------------------------- 1 | (* This will contain the parser type, roster type and connections type *) 2 | 3 | (** The type of an XMPP handler. *) 4 | type t 5 | (* The idea is that this will be called when the on_connect triggers in the unikernel so this will then handle *) 6 | 7 | (* When called this has a few jobs: 8 | - create the parser with the given stream 9 | - initialise the new handler type with the parameters 10 | *) 11 | 12 | (** [create c r s f] creates a new handler. [c] is a connections table of the currently active connections to the server. [r] is the roster for the server. [s] is a stream to receive the incoming data on. [f] is a callback function which can be used to send data back to the user *) 13 | val create : 14 | stream:char Lwt_stream.t -> callback:(string option -> unit) -> hostname:string -> t 15 | 16 | (** [handle t] takes the handler and starts handling the XMPP connection with the client. 17 | 18 | This controls the main operation of the server: 19 | - call parse_stanza on the parser which will return a new stanza 20 | - translates the received stanza into an event type and pass this to the fsm to get a new fsm 21 | - take the actions from the fsm and push necessary data to the callback function, handle roster events and perform lookups on the connections in order to send data to other users 22 | - call parse_stanza again and repeat 23 | *) 24 | val handle : t -> unit Lwt.t 25 | 26 | val to_string : t -> string 27 | -------------------------------------------------------------------------------- /src/jid.ml: -------------------------------------------------------------------------------- 1 | open Astring 2 | open Sexplib.Std 3 | 4 | exception MalformedJID of string 5 | 6 | module Bare = struct 7 | type t = string * string [@@deriving sexp, ord] 8 | 9 | let set_resource resource bare_jid = bare_jid, resource 10 | 11 | exception MalformedBareJID of string 12 | 13 | let of_string str = 14 | match String.cut ~sep:"@" str with 15 | | Some (user, domres) -> 16 | (match String.cut ~sep:"/" domres with 17 | | Some _ -> raise @@ MalformedBareJID str 18 | | None -> user, domres) 19 | | None -> raise @@ MalformedJID str 20 | ;; 21 | end 22 | 23 | module Full = struct 24 | type t = (string * string) * string [@@deriving sexp, ord] 25 | 26 | let to_bare (bare_jid, _) = bare_jid 27 | let set_resource resource (bare_jid, _) = bare_jid, resource 28 | 29 | exception MalformedFullJID of string 30 | 31 | let of_string str = 32 | match String.cut ~sep:"@" str with 33 | | Some (user, domres) -> 34 | (match String.cut ~sep:"/" domres with 35 | | Some (domain, resource) -> (user, domain), resource 36 | | None -> raise @@ MalformedFullJID str) 37 | | None -> raise @@ MalformedJID str 38 | ;; 39 | 40 | let to_string ((user, domain), resource) = user ^ "@" ^ domain ^ "/" ^ resource 41 | end 42 | 43 | module Domain = struct 44 | type t = string [@@deriving sexp] 45 | end 46 | 47 | type t = 48 | | Full_JID of Full.t 49 | | Bare_JID of Bare.t 50 | | Domain of Domain.t 51 | [@@deriving sexp] 52 | 53 | let to_bare_raw = function 54 | | Full_JID (bare_jid, _) -> bare_jid 55 | | Bare_JID bare_jid -> bare_jid 56 | | Domain dom -> 57 | raise @@ MalformedJID ("Not allowed to convert a Domain to a raw jid: " ^ dom) 58 | ;; 59 | 60 | let to_bare = function 61 | | Full_JID (bare_jid, _) -> Bare_JID bare_jid 62 | | Bare_JID bare_jid -> Bare_JID bare_jid 63 | | Domain dom -> 64 | raise @@ MalformedJID ("Not allowed to convert a Domain to a raw jid: " ^ dom) 65 | ;; 66 | 67 | let anon () = "anon-" ^ Uuidm.(to_string (create `V4)) 68 | 69 | let of_string str = 70 | match String.cut ~sep:"@" str with 71 | | Some (user, domres) -> 72 | (match String.cut ~sep:"/" domres with 73 | | Some (domain, resource) -> Full_JID ((user, domain), resource) 74 | | None -> Bare_JID (user, domres)) 75 | | None -> Domain str 76 | ;; 77 | 78 | let create_resource () = Uuidm.(to_string (create `V4)) 79 | 80 | let set_resource resource = function 81 | | Full_JID fjid -> Full_JID (Full.set_resource resource fjid) 82 | | Bare_JID bjid -> Full_JID (Bare.set_resource resource bjid) 83 | | Domain dom -> 84 | raise @@ MalformedJID ("Not allowed to set resource on a Domain: " ^ dom) 85 | ;; 86 | 87 | let to_string = function 88 | | Full_JID ((user, domain), resource) -> user ^ "@" ^ domain ^ "/" ^ resource 89 | | Bare_JID (user, domain) -> user ^ "@" ^ domain 90 | | Domain dom -> dom 91 | ;; 92 | 93 | let%expect_test "make jid" = 94 | let jid = of_string "user@domain/resource" in 95 | print_endline (to_string jid); 96 | [%expect {| user@domain/resource |}] 97 | ;; 98 | 99 | let%expect_test "no resource in jid" = 100 | let jid = of_string "user@domain" in 101 | print_endline (to_string jid); 102 | [%expect {| user@domain |}] 103 | ;; 104 | -------------------------------------------------------------------------------- /src/jid.mli: -------------------------------------------------------------------------------- 1 | (** The type of a Jabber ID *) 2 | 3 | module Bare : sig 4 | type t [@@deriving sexp, ord] 5 | 6 | val of_string : string -> t 7 | end 8 | 9 | module Full : sig 10 | type t [@@deriving sexp, ord] 11 | 12 | val to_bare : t -> Bare.t 13 | val of_string : string -> t 14 | val to_string : t -> string 15 | val set_resource : string -> t -> t 16 | end 17 | 18 | module Domain : sig 19 | type t [@@deriving sexp] 20 | end 21 | 22 | type t = 23 | | Full_JID of Full.t 24 | | Bare_JID of Bare.t 25 | | Domain of Domain.t 26 | [@@deriving sexp] 27 | 28 | val set_resource : string -> t -> t 29 | val anon : unit -> string 30 | val to_bare_raw : t -> Bare.t 31 | val to_bare : t -> t 32 | 33 | (** [of_string s] creates a new jid from the string, splitting it appropriately *) 34 | val of_string : string -> t 35 | 36 | (** [to_string t] returns the string representation of t *) 37 | val to_string : t -> string 38 | 39 | val create_resource : unit -> string 40 | -------------------------------------------------------------------------------- /src/parser.ml: -------------------------------------------------------------------------------- 1 | open Ppx_sexp_conv_lib 2 | open Conv 3 | 4 | type t = 5 | { raw_stream : char Lwt_stream.t sexp_opaque 6 | ; stream : (Markup.signal, Markup.async) Markup.stream sexp_opaque 7 | ; mutable depth : int } 8 | [@@deriving sexp] 9 | 10 | type parse_result = 11 | | Stanza of Stanza.t 12 | | Sasl_auth of Xml.t 13 | | Stream_Element of Stream.t 14 | | Error of string 15 | 16 | exception ParsingError of string 17 | 18 | let make_parser stream = 19 | Markup_lwt.parse_xml 20 | ~report:(fun _ e -> 21 | let error_string = Markup.Error.to_string e in 22 | Lwt.fail (ParsingError error_string) ) 23 | stream 24 | ;; 25 | 26 | let create raw_stream = 27 | let stream = Markup_lwt.lwt_stream raw_stream |> make_parser |> Markup.signals in 28 | {raw_stream; stream; depth = 0} 29 | ;; 30 | 31 | let reset parser = 32 | { raw_stream = parser.raw_stream 33 | ; stream = Markup_lwt.lwt_stream parser.raw_stream |> make_parser |> Markup.signals 34 | ; depth = 0 } 35 | ;; 36 | 37 | let convert_attribute ((namespace, name), value) = 38 | let open Xml in 39 | ( namespace 40 | , match name with 41 | | "from" -> From (Jid.of_string value) 42 | | "to" -> To (Jid.of_string value) 43 | | "id" -> Id value 44 | | "jid" -> Jid (Jid.of_string value) 45 | | "xmlns" -> Xmlns value 46 | | "type" -> Type value 47 | | "ver" -> Ver value 48 | | "version" -> Version value 49 | | "lang" -> Lang value 50 | | "stream" -> Stream value 51 | | "name" -> Name value 52 | | "subscription" -> Subscription value 53 | | "mechanism" -> Mechanism value 54 | | _ -> Other (name, value) ) 55 | ;; 56 | 57 | let convert_attributes attributes = 58 | List.map (fun attr -> convert_attribute attr) attributes 59 | ;; 60 | 61 | let rec parse_children parser = 62 | match%lwt Markup_lwt.next parser.stream with 63 | | exception ParsingError e -> Lwt.return_error e 64 | | Some signal -> 65 | (match signal with 66 | | `Start_element (name, attributes) -> 67 | let tag = name, convert_attributes attributes in 68 | (match%lwt parse_children parser with 69 | | Ok children -> 70 | let element = Xml.Element (tag, children) in 71 | (match%lwt parse_children parser with 72 | | Ok element_list -> Lwt.return_ok (element :: element_list) 73 | | Error e -> Lwt.return_error e) 74 | | Error e -> Lwt.return_error e) 75 | | `End_element -> Lwt.return_ok [] 76 | | `Text ss -> 77 | (match String.trim (String.concat "\n" ss) with 78 | | "" -> parse_children parser 79 | | _ -> 80 | let text = Xml.Text (String.concat "\n" ss) in 81 | (match%lwt parse_children parser with 82 | | Ok element_list -> Lwt.return_ok (text :: element_list) 83 | | Error e -> Lwt.return_error e)) 84 | | _ -> assert false) 85 | | None -> Lwt.return_error "End of parsing stream" 86 | ;; 87 | 88 | let rec parse parser = 89 | match%lwt Markup_lwt.next parser.stream with 90 | | exception ParsingError e -> Lwt.return (Error e) 91 | | Some signal -> 92 | (match signal with 93 | | `Start_element ((namespace, name), attrs) -> 94 | let tag = (namespace, name), convert_attributes attrs in 95 | (match parser.depth with 96 | | 0 -> 97 | (* start of stream *) 98 | (* check it actually is a stream tag *) 99 | if name = "stream" 100 | then ( 101 | parser.depth <- 1; 102 | Lwt.return (Stream_Element (Stream.Header tag)) ) 103 | else 104 | Lwt.return 105 | (Error 106 | ("Invalid initial stanza with name " ^ name ^ ", expected stream header.")) 107 | | 1 -> 108 | (* parse stanza / error / feature *) 109 | (match name with 110 | | "iq" -> 111 | (match%lwt parse_children parser with 112 | | Ok children -> Lwt.return (Stanza (Stanza.Iq (Xml.Element (tag, children)))) 113 | | Error e -> Lwt.return (Error e)) 114 | | "message" -> 115 | (match%lwt parse_children parser with 116 | | Ok children -> 117 | Lwt.return (Stanza (Stanza.Message (Xml.Element (tag, children)))) 118 | | Error e -> Lwt.return (Error e)) 119 | | "presence" -> 120 | (match%lwt parse_children parser with 121 | | Ok children -> 122 | Lwt.return (Stanza (Stanza.Presence (Xml.Element (tag, children)))) 123 | | Error e -> Lwt.return (Error e)) 124 | | "auth" -> 125 | (match%lwt parse_children parser with 126 | | Ok children -> Lwt.return (Sasl_auth (Xml.Element (tag, children))) 127 | | Error e -> Lwt.return (Error e)) 128 | | "stream" -> 129 | parser.depth <- 1; 130 | Lwt.return (Stream_Element (Stream.Header tag)) 131 | | "error" -> Lwt.return (Stream_Element Stream.Error) 132 | | s -> Lwt.return (Error ("Unexpected tag with name: " ^ s))) 133 | | _ -> assert false) 134 | | `End_element -> 135 | (match parser.depth with 136 | | 1 -> (* End of the stream *) 137 | Lwt.return (Stream_Element Stream.Close) 138 | | _ -> Lwt.return (Error "Unexpected end element in parser")) 139 | | `Text ss -> 140 | (match String.trim (String.concat "" ss) with 141 | | "" -> parse parser 142 | | _ -> Lwt.return (Error ("Unexpected Text: " ^ String.concat "\n" ss))) 143 | | `Xml _declaration -> 144 | (* Xml declaration is optional so we can just ignore it as there is nothing to do with it *) 145 | parse parser 146 | | `Doctype _doctype -> Lwt.return (Error "Unexpected Doctype") 147 | | `PI (s1, s2) -> Lwt.return (Error ("Unexpected PI: " ^ s1 ^ ", " ^ s2)) 148 | | `Comment s -> Lwt.return (Error ("Unexpected Comment: " ^ s))) 149 | | None -> Lwt.return (Error "End of parsing stream") 150 | ;; 151 | 152 | let parse_string s = 153 | let parser = create (Lwt_stream.of_string s) in 154 | let out () = 155 | match%lwt parse parser with 156 | | Stanza s -> 157 | print_endline (Stanza.to_string s); 158 | Lwt.return_unit 159 | | Sasl_auth xml -> 160 | print_endline ("Sasl_auth\n" ^ Xml.to_string xml); 161 | Lwt.return_unit 162 | | Stream_Element stream_element -> 163 | print_endline ("Stream_Element\n" ^ Stream.to_string stream_element); 164 | Lwt.return_unit 165 | | Error e -> 166 | print_endline e; 167 | Lwt.return_unit 168 | in 169 | fun () -> Lwt_main.run (out ()) 170 | ;; 171 | 172 | let%expect_test "initial stanza gets returned" = 173 | let pf = parse_string "" in 174 | pf (); 175 | [%expect {| 176 | Stream_Element 177 | |}]; 178 | pf (); 179 | [%expect {| 180 | Stream_Element 181 | |}] 182 | ;; 183 | 184 | let%expect_test "non empty stanza is ok" = 185 | let pf = parse_string "A message!" in 186 | pf (); 187 | [%expect {| 188 | Stream_Element 189 | |}]; 190 | pf (); 191 | [%expect {| 192 | A message! |}]; 193 | pf (); 194 | [%expect {| 195 | Stream_Element 196 | |}] 197 | ;; 198 | 199 | let%expect_test "start end full" = 200 | let pf = 201 | parse_string 202 | "text" 205 | in 206 | pf (); 207 | [%expect 208 | {| 209 | Stream_Element 210 | |}]; 211 | pf (); 212 | [%expect 213 | {| 214 | text |}]; 215 | pf (); 216 | [%expect {| 217 | Stream_Element 218 | |}]; 219 | pf (); 220 | [%expect {| End of parsing stream |}] 221 | ;; 222 | 223 | let%expect_test "resource binding" = 224 | let pf = 225 | parse_string 226 | "balcony" 231 | in 232 | pf (); 233 | [%expect 234 | {| 235 | Stream_Element 236 | |}]; 237 | pf (); 238 | [%expect 239 | {| 240 | balcony |}]; 241 | pf (); 242 | [%expect {| 243 | Stream_Element 244 | |}] 245 | ;; 246 | 247 | let%expect_test "invalid xml" = 248 | let pf = parse_string "" in 249 | pf (); 250 | [%expect {| 251 | Stream_Element 252 | |}]; 253 | pf (); 254 | [%expect {| unmatched start tag 'iq' |}] 255 | ;; 256 | 257 | let%expect_test "whitespace between elements" = 258 | let pf = parse_string " \n " in 259 | pf (); 260 | [%expect {| 261 | Stream_Element 262 | |}]; 263 | pf (); 264 | [%expect {| 265 | |}] 266 | ;; 267 | 268 | let%expect_test "non-whitespace between elements" = 269 | let pf = 270 | parse_string "invalid string n more invalid stuff" 271 | in 272 | pf (); 273 | [%expect {| 274 | Stream_Element 275 | |}]; 276 | pf (); 277 | [%expect {| 278 | Unexpected Text: invalid string |}] 279 | ;; 280 | -------------------------------------------------------------------------------- /src/parser.mli: -------------------------------------------------------------------------------- 1 | (** The type of a parser *) 2 | type t [@@deriving sexp] 3 | 4 | type parse_result = 5 | | Stanza of Stanza.t 6 | | Sasl_auth of Xml.t 7 | | Stream_Element of Stream.t 8 | | Error of string 9 | 10 | (** [create s] creates a new parser from the given stream of input characters *) 11 | val create : char Lwt_stream.t -> t 12 | 13 | val reset : t -> t 14 | 15 | (** [parse_stanza t] will act similarly to parse_xml apart from that it returns a full stanza or in the case of a start of stream, it returns a near-complete stanza *) 16 | val parse : t -> parse_result Lwt.t 17 | -------------------------------------------------------------------------------- /src/rosters.mli: -------------------------------------------------------------------------------- 1 | (** A roster stores information about contacts for a particular user, it also stores information about subscriptions to the user's presence. *) 2 | 3 | module Subscription : sig 4 | type t = 5 | | None 6 | | To 7 | | From 8 | | Both 9 | | Remove 10 | 11 | val to_string : t -> string 12 | end 13 | 14 | module Presence : sig 15 | type t = 16 | | Online 17 | | Offline 18 | [@@deriving sexp] 19 | end 20 | 21 | module Item : sig 22 | type t = 23 | { handle : string 24 | ; subscription : Subscription.t [@default (None : Subscription.t)] 25 | ; ask : bool [@default false] 26 | ; groups : string list } 27 | [@@deriving sexp, make] 28 | 29 | val to_tuple : t -> string * Subscription.t * bool * string list 30 | end 31 | 32 | (** [lock_user user] attempts to acquire a basic lock on the bare user to prevent others from using it. It returns [true] if it is successful in acquiring the lock and [false] otherwise. *) 33 | val lock_user : Jid.Bare.t -> bool Lwt.t 34 | 35 | (** [unlock_user user] unlocks the lock set by [lock_user]. *) 36 | val unlock_user : Jid.Bare.t -> unit Lwt.t 37 | 38 | (** [remove_item user contact] removes the [contact] from the [user]'s roster. *) 39 | val remove_item : Jid.Bare.t -> Jid.Bare.t -> unit Lwt.t 40 | 41 | (** [downgrade_subscription_to user contact] removes the {e to} part of the presence subscription from [user] to [contact]. *) 42 | val downgrade_subscription_to : Jid.Bare.t -> Jid.Bare.t -> unit Lwt.t 43 | 44 | (** [downgrade_subscription_from user contact] removes the {e from} part of the presence subscription from [user] to [contact]. *) 45 | val downgrade_subscription_from : Jid.Bare.t -> Jid.Bare.t -> unit Lwt.t 46 | 47 | (** [upgrade_subscription_to user contact] adds the {e to} part of the presence subscription from [user] to [contact]. *) 48 | val upgrade_subscription_to : Jid.Bare.t -> Jid.Bare.t -> unit Lwt.t 49 | 50 | (** [upgrade_subscription_from user contact] adds the {e from} part of the presence subscription from [user] to [contact]. *) 51 | val upgrade_subscription_from : Jid.Bare.t -> Jid.Bare.t -> unit Lwt.t 52 | 53 | (** [unset_ask user contact] sets the [ask] value to false for the [contact] in the [user]'s roster. *) 54 | val unset_ask : Jid.Bare.t -> Jid.Bare.t -> unit Lwt.t 55 | 56 | (** [set_ask user contact] sets the [ask] value to true for the [contact] in the [user]'s roster. *) 57 | val set_ask : Jid.Bare.t -> Jid.Bare.t -> unit Lwt.t 58 | 59 | (** [set_item ~subscription ~handle ~groups user contact] sets the item for [contact] in the [user]'s roster either by creating a new item and inserting it or updating an existing item. The default for [subscription] is [None], for [handle] is [""] and for [groups] is [[]]. *) 60 | val set_item : 61 | ?subscription:Subscription.t 62 | -> ?handle:string 63 | -> ?groups:string list 64 | -> Jid.Bare.t 65 | -> Jid.Bare.t 66 | -> Item.t Lwt.t 67 | 68 | (** [get_presence user] gets the current presence status for the [user]. *) 69 | val get_presence : Jid.Bare.t -> Presence.t Lwt.t 70 | 71 | val set_presence : Jid.Bare.t -> Presence.t -> unit Lwt.t 72 | 73 | (** [get_ask user contact] gets the current status of a presence subscription ask from [user] to [contact]. *) 74 | val get_ask : Jid.Bare.t -> Jid.Bare.t -> bool option Lwt.t 75 | 76 | (** [get_subscription user contact] gets the subscription from [user] to [contact] if there is one. *) 77 | val get_subscription : Jid.Bare.t -> Jid.Bare.t -> Subscription.t option Lwt.t 78 | 79 | (** [get_item user contact] get the item associated with the [contact] in the [user]'s roster if there is one. *) 80 | val get_item : Jid.Bare.t -> Jid.Bare.t -> Item.t option Lwt.t 81 | 82 | (** [get_items user] returns a list of [(contact, item)] pairs from the [user]'s roster. *) 83 | val get_items : Jid.Bare.t -> (Jid.Bare.t * Item.t) list Lwt.t 84 | 85 | (** [get_subscriptions user] gets the list of [contact]s where the [user] has a subscription to the [contact]. *) 86 | val get_subscriptions : Jid.Bare.t -> Jid.Bare.t list Lwt.t 87 | 88 | (** [get_subscribers user] gets the list of [contact]s where the [contact] has a subscription to the [user]. *) 89 | val get_subscribers : Jid.Bare.t -> Jid.Bare.t list Lwt.t 90 | 91 | (** [to_string ()] returns the string representation of the rosters. *) 92 | val to_string : unit -> string Lwt.t 93 | 94 | (** [clear ()] clears the roster. *) 95 | val clear : unit -> unit Lwt.t 96 | -------------------------------------------------------------------------------- /src/stanza.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | | Message of Xml.t 3 | | Presence of Xml.t 4 | | Iq of Xml.t 5 | [@@deriving sexp] 6 | 7 | let to_xml = function Message xml -> xml | Presence xml -> xml | Iq xml -> xml 8 | let gen_id () = Uuidm.(to_string (create `V4)) 9 | 10 | let create_presence ?(attributes = []) ?atype ?ato ~id ~from children = 11 | let attributes = 12 | match atype with Some t -> ("", Xml.Type t) :: attributes | None -> attributes 13 | in 14 | let attributes = 15 | match id with Some i -> ("", Xml.Id i) :: attributes | None -> attributes 16 | in 17 | let attributes = 18 | match ato with Some ato -> ("", Xml.To ato) :: attributes | None -> attributes 19 | in 20 | Presence (Element ((("", "presence"), ["", Xml.From from] @ attributes), children)) 21 | ;; 22 | 23 | let create_iq ?(attributes = []) ?ato ~atype ~id children = 24 | let attributes = 25 | match ato with Some ato -> ("", Xml.To ato) :: attributes | None -> attributes 26 | in 27 | Iq (Element ((("", "iq"), ["", Xml.Id id; "", Xml.Type atype] @ attributes), children)) 28 | ;; 29 | 30 | let create_iq_error ~from ?ato ~id ~error_type ~error_tag () = 31 | let attributes = match ato with Some target -> ["", Xml.To target] | None -> [] in 32 | Iq 33 | (Element 34 | ( ( ("", "iq") 35 | , ["", Xml.From from; "", Xml.Id id; "", Xml.Type "error"] @ attributes ) 36 | , [ Element 37 | ( (("", "error"), ["", Xml.Type (Actions.error_type_to_string error_type)]) 38 | , [ Element 39 | ( ( ("", error_tag) 40 | , ["", Xml.Xmlns "urn:ietf:params:xml:ns:xmpp-stanzas"] ) 41 | , [] ) ] ) ] )) 42 | ;; 43 | 44 | let create_bind ?(attributes = []) children = 45 | Xml.create 46 | (("", "bind"), ["", Xml.Xmlns "urn:ietf:params:xml:ns:xmpp-bind"] @ attributes) 47 | ~children 48 | ;; 49 | 50 | let create_query children = 51 | Xml.create (("", "query"), ["", Xml.Xmlns "jabber:iq:roster"]) ~children 52 | ;; 53 | 54 | let create_resource ?(attributes = []) children = 55 | Xml.create (("", "resource"), attributes) ~children 56 | ;; 57 | 58 | let create_bind_result ~id ~jid () = 59 | create_iq 60 | ~id 61 | ~atype:"result" 62 | [create_bind [Xml.create (("", "jid"), []) ~children:[Xml.Text (Jid.to_string jid)]]] 63 | ;; 64 | 65 | let create_roster_get_result ~id ~ato items = 66 | create_iq 67 | ~id 68 | ~atype:"result" 69 | ~ato 70 | [ create_query 71 | (List.map 72 | (fun (jid, item) -> 73 | let handle, subscription, _ask, groups = Rosters.Item.to_tuple item in 74 | Xml.create 75 | ( ("", "item") 76 | , [ "", Xml.Jid (Bare_JID jid) 77 | ; "", Xml.Name handle 78 | ; "", Xml.Subscription (Rosters.Subscription.to_string subscription) ] 79 | ) 80 | ~children: 81 | (List.map 82 | (fun group -> 83 | Xml.create (("", "group"), []) ~children:[Xml.Text group] ) 84 | groups) ) 85 | items) ] 86 | ;; 87 | 88 | let create_roster_set_result ~id ~ato = create_iq ~id ~atype:"result" ~ato [] 89 | 90 | let create_roster_push ~id ~ato (jid, item) = 91 | let handle, subscription, _ask, groups = Rosters.Item.to_tuple item in 92 | let attributes = [] in 93 | let attributes = 94 | match handle with "" -> attributes | h -> ("", Xml.Name h) :: attributes 95 | in 96 | let attributes = 97 | ("", Xml.Subscription (Rosters.Subscription.to_string subscription)) :: attributes 98 | in 99 | create_iq 100 | ~id 101 | ~ato 102 | ~atype:"set" 103 | [ create_query 104 | [ Xml.create 105 | (("", "item"), ["", Xml.Jid jid] @ attributes) 106 | ~children: 107 | (List.map 108 | (fun group -> Xml.create (("", "group"), []) ~children:[Xml.Text group]) 109 | groups) ] ] 110 | ;; 111 | 112 | let rec get_subscription = function 113 | | [] -> None 114 | | (_, Xml.Subscription sub) :: _ -> Some sub 115 | | _ :: attrs -> get_subscription attrs 116 | ;; 117 | 118 | let rec get_id_exn = function 119 | | [] -> raise Not_found 120 | | (_, Xml.Id id) :: _ -> id 121 | | _ :: attrs -> get_id_exn attrs 122 | ;; 123 | 124 | let rec get_id = function 125 | | [] -> None 126 | | (_, Xml.Id id) :: _ -> Some id 127 | | _ :: attrs -> get_id attrs 128 | ;; 129 | 130 | let rec get_from = function 131 | | [] -> raise Not_found 132 | | (_, Xml.From jid) :: _ -> jid 133 | | _ :: attrs -> get_from attrs 134 | ;; 135 | 136 | let rec get_to = function 137 | | [] -> raise Not_found 138 | | (_, Xml.To jid) :: _ -> jid 139 | | _ :: attrs -> get_to attrs 140 | ;; 141 | 142 | let rec get_type = function 143 | | [] -> None 144 | | (_, Xml.Type t) :: _ -> Some t 145 | | _ :: attrs -> get_type attrs 146 | ;; 147 | 148 | let rec get_version = function 149 | | [] -> raise Not_found 150 | | (_, Xml.Version v) :: _ -> v 151 | | _ :: attrs -> get_version attrs 152 | ;; 153 | 154 | let rec get_jid = function 155 | | [] -> raise Not_found 156 | | (_, Xml.Jid jid) :: _ -> jid 157 | | _ :: attrs -> get_jid attrs 158 | ;; 159 | 160 | let rec get_name = function 161 | | [] -> None 162 | | (_, Xml.Name name) :: _ -> Some name 163 | | _ :: attrs -> get_name attrs 164 | ;; 165 | 166 | let to_string = function 167 | | Message xml -> Xml.to_string xml 168 | | Presence xml -> Xml.to_string xml 169 | | Iq xml -> Xml.to_string xml 170 | ;; 171 | -------------------------------------------------------------------------------- /src/stanza.mli: -------------------------------------------------------------------------------- 1 | (** The type of a Stanza. *) 2 | type t = 3 | | Message of Xml.t 4 | | Presence of Xml.t 5 | | Iq of Xml.t 6 | 7 | (** [to_xml t] returns the xml element contained within the stanza type [t]. *) 8 | val to_xml : t -> Xml.t 9 | 10 | (** [gen_id ()] generates a new string to use as an id. *) 11 | val gen_id : unit -> string 12 | 13 | (** [create_presence ~attributes ~atype ~ato ~id ~from children] creates a presence stanza with the given attributes and children. *) 14 | val create_presence : 15 | ?attributes:Xml.attribute list 16 | -> ?atype:string 17 | -> ?ato:Jid.t 18 | -> id:string option 19 | -> from:Jid.t 20 | -> Xml.t list 21 | -> t 22 | 23 | (** [create_iq ~attributes ~ato ~atype ~id children] creates an iq stanza with the given attributes and children. *) 24 | val create_iq : 25 | ?attributes:Xml.attribute list 26 | -> ?ato:Jid.t 27 | -> atype:string 28 | -> id:string 29 | -> Xml.t list 30 | -> t 31 | 32 | (** [create_iq_error ~from ~ato ~id ~error_type ~error_tag] creates an iq error stanza with the given attributes. *) 33 | val create_iq_error : 34 | from:Jid.t 35 | -> ?ato:Jid.t 36 | -> id:string 37 | -> error_type:Actions.error_type 38 | -> error_tag:string 39 | -> unit 40 | -> t 41 | 42 | (** [create_bind ~attributes children] creates an iq bind stanza with the given attributes and children. *) 43 | val create_bind : ?attributes:Xml.attribute list -> Xml.t list -> Xml.t 44 | 45 | (** [create_resource ~attributes children] creates a resource bind xml element with the given attributes and children. *) 46 | val create_resource : ?attributes:Xml.attribute list -> Xml.t list -> Xml.t 47 | 48 | val create_bind_result : id:string -> jid:Jid.t -> unit -> t 49 | 50 | val create_roster_get_result : 51 | id:string -> ato:Jid.t -> (Jid.Bare.t * Rosters.Item.t) list -> t 52 | 53 | val create_roster_set_result : id:string -> ato:Jid.t -> t 54 | val create_roster_push : id:string -> ato:Jid.t -> Jid.t * Rosters.Item.t -> t 55 | 56 | (** [to_string t] takes a stanza [t] and returns the string representation of it *) 57 | val to_string : t -> string 58 | 59 | val get_subscription : Xml.attribute list -> string option 60 | val get_id_exn : Xml.attribute list -> string 61 | val get_id : Xml.attribute list -> string option 62 | val get_from : Xml.attribute list -> Jid.t 63 | val get_to : Xml.attribute list -> Jid.t 64 | val get_type : Xml.attribute list -> string option 65 | val get_version : Xml.attribute list -> string 66 | val get_jid : Xml.attribute list -> Jid.t 67 | val get_name : Xml.attribute list -> string option 68 | -------------------------------------------------------------------------------- /src/state.ml: -------------------------------------------------------------------------------- 1 | (* The state representing the current status of the connection *) 2 | open Events 3 | 4 | type state = 5 | | IDLE 6 | | SASL_NEGOTIATION 7 | | NEGOTIATING 8 | | CONNECTED 9 | | CLOSED 10 | [@@deriving sexp] 11 | 12 | type t = {state : state} [@@deriving sexp] 13 | 14 | let initial = {state = IDLE} 15 | let to_string t = Sexplib.Sexp.to_string_hum @@ sexp_of_t t 16 | 17 | let closed = 18 | ( {state = CLOSED} 19 | , [ Actions.UPDATE_PRESENCE {status = Rosters.Presence.Offline; xml = None} 20 | ; Actions.REMOVE_FROM_CONNECTIONS 21 | ; Actions.CLOSE ] 22 | , [Actions.EXIT] ) 23 | ;; 24 | 25 | let closed_with_error e = 26 | ( {state = CLOSED} 27 | , [ Actions.UPDATE_PRESENCE {status = Rosters.Presence.Offline; xml = None} 28 | ; Actions.REMOVE_FROM_CONNECTIONS 29 | ; Actions.ERROR e ] 30 | , [Actions.EXIT] ) 31 | ;; 32 | 33 | let handle_idle t = function 34 | | STREAM_HEADER {version} -> 35 | if float_of_string version >= 1.0 36 | then 37 | ( {state = SASL_NEGOTIATION} 38 | , [Actions.SEND_STREAM_HEADER; Actions.SEND_STREAM_FEATURES_SASL] 39 | , [] ) 40 | else closed_with_error "Must use version >= 1.0" 41 | | SASL_AUTH _ -> closed_with_error "No stream" 42 | | ANONYMOUS_SASL_AUTH -> closed_with_error "No stream" 43 | | RESOURCE_BIND_SERVER_GEN _ -> closed_with_error "No stream" 44 | | RESOURCE_BIND_CLIENT_GEN _ -> closed_with_error "No stream" 45 | | SESSION_START _id -> closed_with_error "No stream" 46 | | STREAM_CLOSE -> closed_with_error "No stream" 47 | | ERROR e -> closed_with_error e 48 | | ROSTER_GET _ -> closed_with_error "No stream" 49 | | ROSTER_SET _ -> closed_with_error "No stream" 50 | | ROSTER_REMOVE _ -> closed_with_error "No stream" 51 | | SUBSCRIPTION_REQUEST _ -> closed_with_error "No stream" 52 | | PRESENCE_UPDATE _ -> closed_with_error "No stream" 53 | | IQ_ERROR _ -> closed_with_error "No stream" 54 | | MESSAGE _ -> closed_with_error "No stream" 55 | | LOG_OUT -> closed_with_error "No stream" 56 | | NOOP -> t, [], [] 57 | | SUBSCRIPTION_APPROVAL _ -> closed_with_error "No stream" 58 | | SUBSCRIPTION_CANCELLATION _ -> closed_with_error "No stream" 59 | | SUBSCRIPTION_REMOVAL _ -> closed_with_error "No stream" 60 | ;; 61 | 62 | let handle_sasl_negotiation t = function 63 | | STREAM_HEADER _ -> 64 | closed_with_error "Unexpected stream header during sasl negotiation" 65 | | SASL_AUTH {user; _} -> 66 | ( {state = NEGOTIATING} 67 | , [Actions.SET_USER user; Actions.SEND_SASL_SUCCESS] 68 | , [Actions.RESET_PARSER] ) 69 | | ANONYMOUS_SASL_AUTH -> 70 | ( {state = NEGOTIATING} 71 | , [Actions.SET_USER_ANON; Actions.SEND_SASL_SUCCESS] 72 | , [Actions.RESET_PARSER] ) 73 | | RESOURCE_BIND_SERVER_GEN _ -> closed_with_error "Not finished SASL" 74 | | RESOURCE_BIND_CLIENT_GEN _ -> closed_with_error "Not finished SASL" 75 | | SESSION_START _id -> 76 | closed_with_error "Unexpected session start stanza during sasl negotiation" 77 | | STREAM_CLOSE -> closed_with_error "Unexpected stream close during sasl negotiation" 78 | | ERROR e -> closed_with_error e 79 | | ROSTER_GET _ -> closed_with_error "Unexpected roster get during sasl negotiation" 80 | | ROSTER_SET _ -> closed_with_error "Unexpected roster set during sasl negotiation" 81 | | ROSTER_REMOVE _ -> 82 | closed_with_error "Unexpected roster remove during sasl negotiation" 83 | | SUBSCRIPTION_REQUEST _ -> 84 | closed_with_error "Unexpected subscription request during sasl negotiation" 85 | | PRESENCE_UPDATE _ -> 86 | closed_with_error "Unexpected presence update during sasl negotiation" 87 | | IQ_ERROR {error_type; error_tag; id} -> 88 | {state = SASL_NEGOTIATION}, [Actions.IQ_ERROR {error_type; error_tag; id}], [] 89 | | MESSAGE _ -> closed_with_error "Unexpected message during sasl negotiation" 90 | | LOG_OUT -> 91 | closed_with_error "Unexpected presence for log out during sasl negotiation" 92 | | NOOP -> t, [], [] 93 | | SUBSCRIPTION_APPROVAL _ -> 94 | closed_with_error "Unexpected subscription approval during sasl negotiation" 95 | | SUBSCRIPTION_CANCELLATION _ -> 96 | closed_with_error "Unexpected subscription cancellation during sasl negotiation" 97 | | SUBSCRIPTION_REMOVAL _ -> 98 | closed_with_error "Unexpected subscription removal during sasl negotiation" 99 | ;; 100 | 101 | let just_connected actions = 102 | {state = CONNECTED}, [Actions.PROBE_PRESENCE; Actions.ADD_TO_CONNECTIONS] @ actions, [] 103 | ;; 104 | 105 | let handle_negotiating t = function 106 | | STREAM_HEADER {version} -> 107 | if float_of_string version >= 1.0 108 | then 109 | ( {state = NEGOTIATING} 110 | , [Actions.SEND_STREAM_HEADER; Actions.SEND_STREAM_FEATURES] 111 | , [] ) 112 | else closed_with_error "Must use version >= 1.0" 113 | | SASL_AUTH _ -> closed_with_error "Already negotiated sasl" 114 | | ANONYMOUS_SASL_AUTH -> closed_with_error "Already negotiated sasl" 115 | | RESOURCE_BIND_SERVER_GEN {id} -> 116 | {state = NEGOTIATING}, [Actions.SET_JID_RESOURCE {id; resource = None}], [] 117 | | RESOURCE_BIND_CLIENT_GEN {id; resource} -> 118 | {state = NEGOTIATING}, [Actions.SET_JID_RESOURCE {id; resource = Some resource}], [] 119 | | SESSION_START id -> just_connected [Actions.SESSION_START_SUCCESS id] 120 | | STREAM_CLOSE -> 121 | (* the stream can close during negotiation so close our direction too *) 122 | closed 123 | | ERROR e -> closed_with_error e 124 | | ROSTER_GET id -> just_connected [Actions.GET_ROSTER id] 125 | | ROSTER_SET {id; target; handle; groups} -> 126 | just_connected 127 | [Actions.SET_ROSTER {id; target = Jid.to_bare_raw target; handle; groups}] 128 | | ROSTER_REMOVE {id; target} -> 129 | just_connected 130 | [ Actions.ROSTER_REMOVE {id; target} 131 | ; Actions.PUSH_ROSTER {ato = None; contact = target} ] 132 | | SUBSCRIPTION_REQUEST {ato; xml} -> 133 | just_connected 134 | [ Actions.SUBSCRIPTION_REQUEST {ato; xml; from = None} 135 | ; Actions.PUSH_ROSTER {ato = None; contact = ato} ] 136 | | PRESENCE_UPDATE {status; xml} -> 137 | just_connected [Actions.UPDATE_PRESENCE {status; xml}] 138 | | IQ_ERROR {error_type; error_tag; id} -> 139 | {state = NEGOTIATING}, [Actions.IQ_ERROR {error_type; error_tag; id}], [] 140 | | MESSAGE {ato; message} -> just_connected [Actions.MESSAGE {ato; message}] 141 | | LOG_OUT -> closed 142 | | NOOP -> t, [], [] 143 | | SUBSCRIPTION_APPROVAL {ato; xml} -> 144 | just_connected 145 | [ Actions.SUBSCRIPTION_APPROVAL {ato; xml; from = None} 146 | ; Actions.ROSTER_SET_FROM ato 147 | ; Actions.PUSH_ROSTER {ato = None; contact = ato} 148 | ; Actions.SEND_CURRENT_PRESENCE ato ] 149 | | SUBSCRIPTION_CANCELLATION {user} -> 150 | just_connected [Actions.SUBSCRIPTION_CANCELLATION {user; force = false}] 151 | | SUBSCRIPTION_REMOVAL {contact} -> 152 | just_connected [Actions.SUBSCRIPTION_REMOVAL {contact}] 153 | ;; 154 | 155 | let handle_connected t = function 156 | | STREAM_HEADER _ -> closed_with_error "Not expecting stream header" 157 | | SASL_AUTH _ -> closed_with_error "Already negotiated sasl" 158 | | ANONYMOUS_SASL_AUTH -> closed_with_error "Already negotiated sasl" 159 | | RESOURCE_BIND_SERVER_GEN _ -> closed_with_error "Already connected" 160 | | RESOURCE_BIND_CLIENT_GEN _ -> closed_with_error "Already connected" 161 | | SESSION_START id -> {state = CONNECTED}, [Actions.SESSION_START_SUCCESS id], [] 162 | | STREAM_CLOSE -> closed 163 | | ERROR e -> closed_with_error e 164 | | ROSTER_GET id -> {state = CONNECTED}, [Actions.GET_ROSTER id], [] 165 | | ROSTER_SET {id; target; handle; groups} -> 166 | ( {state = CONNECTED} 167 | , [Actions.SET_ROSTER {id; target = Jid.to_bare_raw target; handle; groups}] 168 | , [] ) 169 | | ROSTER_REMOVE {id; target} -> 170 | ( {state = CONNECTED} 171 | , [ Actions.ROSTER_REMOVE {id; target} 172 | ; Actions.PUSH_ROSTER {ato = None; contact = target} ] 173 | , [] ) 174 | | SUBSCRIPTION_REQUEST {ato; xml} -> 175 | ( {state = CONNECTED} 176 | , [ Actions.SUBSCRIPTION_REQUEST {ato; xml; from = None} 177 | ; Actions.PUSH_ROSTER {ato = None; contact = ato} ] 178 | , [] ) 179 | | PRESENCE_UPDATE {status; xml} -> 180 | {state = CONNECTED}, [Actions.UPDATE_PRESENCE {status; xml}], [] 181 | | IQ_ERROR {error_type; error_tag; id} -> 182 | {state = CONNECTED}, [Actions.IQ_ERROR {error_type; error_tag; id}], [] 183 | | MESSAGE {ato; message} -> {state = CONNECTED}, [Actions.MESSAGE {ato; message}], [] 184 | | LOG_OUT -> closed 185 | | NOOP -> t, [], [] 186 | | SUBSCRIPTION_APPROVAL {ato; xml} -> 187 | ( {state = CONNECTED} 188 | , [ Actions.SUBSCRIPTION_APPROVAL {ato; xml; from = None} 189 | ; Actions.ROSTER_SET_FROM ato 190 | ; Actions.PUSH_ROSTER {ato = None; contact = ato} 191 | ; Actions.SEND_CURRENT_PRESENCE ato ] 192 | , [] ) 193 | | SUBSCRIPTION_CANCELLATION {user} -> 194 | {state = CONNECTED}, [Actions.SUBSCRIPTION_CANCELLATION {user; force = false}], [] 195 | | SUBSCRIPTION_REMOVAL {contact} -> 196 | {state = CONNECTED}, [Actions.SUBSCRIPTION_REMOVAL {contact}], [] 197 | ;; 198 | 199 | let handle_closed t = function 200 | | STREAM_HEADER _s -> closed_with_error "Not expecting stream header" 201 | | SASL_AUTH _ -> closed_with_error "Already negotiated sasl" 202 | | ANONYMOUS_SASL_AUTH -> closed_with_error "Already negotiated sasl" 203 | | RESOURCE_BIND_SERVER_GEN _ -> closed_with_error "Connection closed" 204 | | RESOURCE_BIND_CLIENT_GEN _ -> closed_with_error "Connection closed" 205 | | SESSION_START _id -> closed_with_error "Not expecting session start" 206 | | STREAM_CLOSE -> 207 | (* shouldn't receive another close after being closed *) 208 | closed_with_error "Not expecting a close" 209 | | ERROR e -> closed_with_error e 210 | | ROSTER_GET _ -> closed_with_error "already closed" 211 | | ROSTER_SET _ -> closed_with_error "already closed" 212 | | ROSTER_REMOVE _ -> closed_with_error "already closed" 213 | | SUBSCRIPTION_REQUEST _ -> closed_with_error "already closed" 214 | | PRESENCE_UPDATE _ -> closed_with_error "already closed" 215 | | IQ_ERROR _ -> closed_with_error "already closed" 216 | | MESSAGE _ -> closed_with_error "already closed" 217 | | LOG_OUT -> closed 218 | | NOOP -> t, [], [] 219 | | SUBSCRIPTION_APPROVAL _ -> closed_with_error "already closed" 220 | | SUBSCRIPTION_CANCELLATION _ -> closed_with_error "already closed" 221 | | SUBSCRIPTION_REMOVAL _ -> closed_with_error "already closed" 222 | ;; 223 | 224 | let handle t event = 225 | match t.state with 226 | | IDLE -> handle_idle t event 227 | | SASL_NEGOTIATION -> handle_sasl_negotiation t event 228 | | NEGOTIATING -> handle_negotiating t event 229 | | CONNECTED -> handle_connected t event 230 | | CLOSED -> handle_closed t event 231 | ;; 232 | 233 | let%expect_test "create" = 234 | let fsm = initial in 235 | print_endline (to_string fsm); 236 | [%expect {| ((state IDLE)) |}] 237 | ;; 238 | 239 | let%expect_test "idle to negotiating" = 240 | let fsm = initial in 241 | let fsm, actions, _handler_actions = 242 | handle fsm (Events.STREAM_HEADER {version = "1.0"}) 243 | in 244 | print_endline (to_string fsm); 245 | [%expect {| ((state SASL_NEGOTIATION)) |}]; 246 | let strings = List.map (fun a -> Utils.mask_id @@ Actions.to_string a) actions in 247 | List.iter (Printf.printf "%s\n") strings; 248 | [%expect {| 249 | SEND_STREAM_HEADER 250 | SEND_STREAM_FEATURES_SASL |}] 251 | ;; 252 | 253 | let%expect_test "idle to negotiating with > 1.0" = 254 | let fsm = initial in 255 | let fsm, actions, _handler_actions = 256 | handle fsm (Events.STREAM_HEADER {version = "2.0"}) 257 | in 258 | print_endline (to_string fsm); 259 | [%expect {| ((state SASL_NEGOTIATION)) |}]; 260 | let strings = List.map (fun a -> Utils.mask_id @@ Actions.to_string a) actions in 261 | List.iter (Printf.printf "%s\n") strings; 262 | [%expect {| 263 | SEND_STREAM_HEADER 264 | SEND_STREAM_FEATURES_SASL |}] 265 | ;; 266 | 267 | let%expect_test "negotiating to closing" = 268 | let fsm = initial in 269 | let fsm, actions, _handler_actions = 270 | handle fsm (Events.STREAM_HEADER {version = "1.0"}) 271 | in 272 | print_endline (to_string fsm); 273 | [%expect {| ((state SASL_NEGOTIATION)) |}]; 274 | let strings = List.map (fun a -> Utils.mask_id @@ Actions.to_string a) actions in 275 | List.iter (Printf.printf "%s\n") strings; 276 | [%expect {| 277 | SEND_STREAM_HEADER 278 | SEND_STREAM_FEATURES_SASL |}]; 279 | let fsm, actions, _handler_actions = handle fsm Events.STREAM_CLOSE in 280 | print_endline (to_string fsm); 281 | [%expect {| ((state CLOSED)) |}]; 282 | let strings = List.map (fun a -> Actions.to_string a) actions in 283 | List.iter (Printf.printf "%s\n") strings; 284 | [%expect 285 | {| 286 | (UPDATE_PRESENCE (status Offline) (xml ())) 287 | REMOVE_FROM_CONNECTIONS 288 | (ERROR "Unexpected stream close during sasl negotiation") |}] 289 | ;; 290 | 291 | let%expect_test "sasl negotiation" = 292 | let fsm = initial in 293 | let fsm, actions, _handler_actions = 294 | handle fsm (Events.STREAM_HEADER {version = "1.0"}) 295 | in 296 | print_endline (to_string fsm); 297 | [%expect {| ((state SASL_NEGOTIATION)) |}]; 298 | let strings = List.map (fun a -> Actions.to_string a) actions in 299 | List.iter (Printf.printf "%s\n") strings; 300 | [%expect {| 301 | SEND_STREAM_HEADER 302 | SEND_STREAM_FEATURES_SASL |}]; 303 | let fsm, actions, _handler_actions = 304 | handle fsm (Events.SASL_AUTH {user = "juliet"; password = ""}) 305 | in 306 | print_endline (to_string fsm); 307 | [%expect {| ((state NEGOTIATING)) |}]; 308 | let strings = List.map (fun a -> Actions.to_string a) actions in 309 | List.iter (Printf.printf "%s\n") strings; 310 | [%expect {| 311 | (SET_USER juliet) 312 | SEND_SASL_SUCCESS |}]; 313 | let fsm, actions, _handler_actions = 314 | handle fsm (Events.RESOURCE_BIND_SERVER_GEN {id = "id"}) 315 | in 316 | print_endline (to_string fsm); 317 | [%expect {| ((state NEGOTIATING)) |}]; 318 | let strings = List.map (fun a -> Actions.to_string a) actions in 319 | List.iter (fun s -> print_endline s) strings; 320 | [%expect {| 321 | (SET_JID_RESOURCE (id id) (resource ())) |}]; 322 | let fsm, actions, _handler_actions = handle fsm Events.STREAM_CLOSE in 323 | print_endline (to_string fsm); 324 | [%expect {| ((state CLOSED)) |}]; 325 | let strings = List.map (fun a -> Actions.to_string a) actions in 326 | List.iter (Printf.printf "%s\n") strings; 327 | [%expect 328 | {| 329 | (UPDATE_PRESENCE (status Offline) (xml ())) 330 | REMOVE_FROM_CONNECTIONS 331 | CLOSE |}] 332 | ;; 333 | 334 | let%expect_test "bind resource" = 335 | let fsm = initial in 336 | let fsm, actions, _handler_actions = 337 | handle fsm (Events.STREAM_HEADER {version = "1.0"}) 338 | in 339 | print_endline (to_string fsm); 340 | [%expect {| ((state SASL_NEGOTIATION)) |}]; 341 | let strings = List.map (fun a -> Actions.to_string a) actions in 342 | List.iter (Printf.printf "%s\n") strings; 343 | [%expect {| 344 | SEND_STREAM_HEADER 345 | SEND_STREAM_FEATURES_SASL |}]; 346 | let fsm, actions, _handler_actions = 347 | handle fsm (Events.SASL_AUTH {user = "juliet"; password = ""}) 348 | in 349 | print_endline (to_string fsm); 350 | [%expect {| ((state NEGOTIATING)) |}]; 351 | let strings = List.map (fun a -> Actions.to_string a) actions in 352 | List.iter (Printf.printf "%s\n") strings; 353 | [%expect {| 354 | (SET_USER juliet) 355 | SEND_SASL_SUCCESS |}]; 356 | let fsm, actions, _handler_actions = 357 | handle fsm (Events.RESOURCE_BIND_SERVER_GEN {id = "id"}) 358 | in 359 | print_endline (to_string fsm); 360 | [%expect {| ((state NEGOTIATING)) |}]; 361 | let strings = List.map (fun a -> Actions.to_string a) actions in 362 | List.iter (fun s -> print_endline s) strings; 363 | [%expect {| 364 | (SET_JID_RESOURCE (id id) (resource ())) |}]; 365 | let fsm, actions, _handler_actions = handle fsm Events.STREAM_CLOSE in 366 | print_endline (to_string fsm); 367 | [%expect {| ((state CLOSED)) |}]; 368 | let strings = List.map (fun a -> Actions.to_string a) actions in 369 | List.iter (Printf.printf "%s\n") strings; 370 | [%expect 371 | {| 372 | (UPDATE_PRESENCE (status Offline) (xml ())) 373 | REMOVE_FROM_CONNECTIONS 374 | CLOSE |}] 375 | ;; 376 | 377 | let%expect_test "bind resource client" = 378 | let fsm = initial in 379 | let fsm, actions, _handler_actions = 380 | handle fsm (Events.STREAM_HEADER {version = "1.0"}) 381 | in 382 | print_endline (to_string fsm); 383 | [%expect {| ((state SASL_NEGOTIATION)) |}]; 384 | let strings = List.map (fun a -> Actions.to_string a) actions in 385 | List.iter (Printf.printf "%s\n") strings; 386 | [%expect {| 387 | SEND_STREAM_HEADER 388 | SEND_STREAM_FEATURES_SASL |}]; 389 | let fsm, actions, _handler_actions = 390 | handle fsm (Events.SASL_AUTH {user = "juliet"; password = ""}) 391 | in 392 | print_endline (to_string fsm); 393 | [%expect {| ((state NEGOTIATING)) |}]; 394 | let strings = List.map (fun a -> Actions.to_string a) actions in 395 | List.iter (Printf.printf "%s\n") strings; 396 | [%expect {| 397 | (SET_USER juliet) 398 | SEND_SASL_SUCCESS |}]; 399 | let fsm, actions, _handler_actions = 400 | handle fsm (Events.RESOURCE_BIND_CLIENT_GEN {id = "id"; resource = "client-res"}) 401 | in 402 | print_endline (to_string fsm); 403 | [%expect {| ((state NEGOTIATING)) |}]; 404 | let strings = List.map (fun a -> Actions.to_string a) actions in 405 | List.iter (fun s -> print_endline s) strings; 406 | [%expect {| 407 | (SET_JID_RESOURCE (id id) (resource (client-res))) |}]; 408 | let fsm, actions, _handler_actions = handle fsm Events.STREAM_CLOSE in 409 | print_endline (to_string fsm); 410 | [%expect {| ((state CLOSED)) |}]; 411 | let strings = List.map (fun a -> Actions.to_string a) actions in 412 | List.iter (Printf.printf "%s\n") strings; 413 | [%expect 414 | {| 415 | (UPDATE_PRESENCE (status Offline) (xml ())) 416 | REMOVE_FROM_CONNECTIONS 417 | CLOSE |}] 418 | ;; 419 | 420 | let%expect_test "roster get" = 421 | let fsm = initial in 422 | let fsm, actions, _handler_actions = 423 | handle fsm (Events.STREAM_HEADER {version = "1.0"}) 424 | in 425 | print_endline (to_string fsm); 426 | [%expect {| ((state SASL_NEGOTIATION)) |}]; 427 | List.map (fun a -> Actions.to_string a) actions |> List.iter (Printf.printf "%s\n"); 428 | [%expect {| 429 | SEND_STREAM_HEADER 430 | SEND_STREAM_FEATURES_SASL |}]; 431 | let fsm, actions, _handler_actions = 432 | handle fsm (Events.SASL_AUTH {user = "juliet"; password = ""}) 433 | in 434 | print_endline (to_string fsm); 435 | [%expect {| ((state NEGOTIATING)) |}]; 436 | let strings = List.map (fun a -> Actions.to_string a) actions in 437 | List.iter (Printf.printf "%s\n") strings; 438 | [%expect {| 439 | (SET_USER juliet) 440 | SEND_SASL_SUCCESS |}]; 441 | let fsm, actions, _handler_actions = 442 | handle fsm (Events.RESOURCE_BIND_CLIENT_GEN {id = "id"; resource = "client-res"}) 443 | in 444 | print_endline (to_string fsm); 445 | [%expect {| ((state NEGOTIATING)) |}]; 446 | List.map (fun a -> Actions.to_string a) actions |> List.iter (fun s -> print_endline s); 447 | [%expect {| (SET_JID_RESOURCE (id id) (resource (client-res))) |}]; 448 | let fsm, actions, _handler_actions = handle fsm (Events.ROSTER_GET "some_id") in 449 | print_endline (to_string fsm); 450 | [%expect {| ((state CONNECTED)) |}]; 451 | List.map (fun a -> Actions.to_string a) actions |> List.iter (fun s -> print_endline s); 452 | [%expect {| 453 | PROBE_PRESENCE 454 | ADD_TO_CONNECTIONS 455 | (GET_ROSTER some_id) |}]; 456 | let fsm, actions, _handler_actions = handle fsm Events.STREAM_CLOSE in 457 | print_endline (to_string fsm); 458 | [%expect {| ((state CLOSED)) |}]; 459 | List.map (fun a -> Actions.to_string a) actions |> List.iter (Printf.printf "%s\n"); 460 | [%expect 461 | {| 462 | (UPDATE_PRESENCE (status Offline) (xml ())) 463 | REMOVE_FROM_CONNECTIONS 464 | CLOSE |}] 465 | ;; 466 | 467 | let%expect_test "roster set" = 468 | let fsm = initial in 469 | let fsm, actions, _handler_actions = 470 | handle fsm (Events.STREAM_HEADER {version = "1.0"}) 471 | in 472 | print_endline (to_string fsm); 473 | [%expect {| ((state SASL_NEGOTIATION)) |}]; 474 | List.map (fun a -> Actions.to_string a) actions |> List.iter (Printf.printf "%s\n"); 475 | [%expect {| 476 | SEND_STREAM_HEADER 477 | SEND_STREAM_FEATURES_SASL |}]; 478 | let fsm, actions, _handler_actions = 479 | handle fsm (Events.SASL_AUTH {user = "juliet"; password = ""}) 480 | in 481 | print_endline (to_string fsm); 482 | [%expect {| ((state NEGOTIATING)) |}]; 483 | let strings = List.map (fun a -> Actions.to_string a) actions in 484 | List.iter (Printf.printf "%s\n") strings; 485 | [%expect {| 486 | (SET_USER juliet) 487 | SEND_SASL_SUCCESS |}]; 488 | let fsm, actions, _handler_actions = 489 | handle fsm (Events.RESOURCE_BIND_CLIENT_GEN {id = "id"; resource = "client-res"}) 490 | in 491 | print_endline (to_string fsm); 492 | [%expect {| ((state NEGOTIATING)) |}]; 493 | List.map (fun a -> Actions.to_string a) actions |> List.iter (fun s -> print_endline s); 494 | [%expect {| (SET_JID_RESOURCE (id id) (resource (client-res))) |}]; 495 | let fsm, actions, _handler_actions = handle fsm (Events.ROSTER_GET "some_id") in 496 | print_endline (to_string fsm); 497 | [%expect {| ((state CONNECTED)) |}]; 498 | List.map (fun a -> Actions.to_string a) actions |> List.iter (fun s -> print_endline s); 499 | [%expect {| 500 | PROBE_PRESENCE 501 | ADD_TO_CONNECTIONS 502 | (GET_ROSTER some_id) |}]; 503 | let fsm, actions, _handler_actions = 504 | handle 505 | fsm 506 | (Events.ROSTER_SET 507 | { id = "some_id" 508 | ; target = Jid.of_string "nurse@example.com" 509 | ; handle = "Nurse" 510 | ; groups = ["Servants"] }) 511 | in 512 | print_endline (to_string fsm); 513 | [%expect {| ((state CONNECTED)) |}]; 514 | List.map (fun a -> Actions.to_string a) actions |> List.iter (fun s -> print_endline s); 515 | [%expect 516 | {| 517 | (SET_ROSTER (id some_id) (target (nurse example.com)) (handle Nurse) 518 | (groups (Servants))) |}]; 519 | let fsm, actions, _handler_actions = handle fsm Events.STREAM_CLOSE in 520 | print_endline (to_string fsm); 521 | [%expect {| ((state CLOSED)) |}]; 522 | List.map (fun a -> Actions.to_string a) actions |> List.iter (Printf.printf "%s\n"); 523 | [%expect 524 | {| 525 | (UPDATE_PRESENCE (status Offline) (xml ())) 526 | REMOVE_FROM_CONNECTIONS 527 | CLOSE |}] 528 | ;; 529 | -------------------------------------------------------------------------------- /src/state.mli: -------------------------------------------------------------------------------- 1 | (** State machine representing the transitions for the XMPP input events. The events drive the new states of the state machine and it returns actions to be taken, typically of the form of writing data back to the user. *) 2 | 3 | (** The type of a state machine *) 4 | type t [@@deriving sexp] 5 | 6 | (** Create a state machine in the initial state *) 7 | val initial : t 8 | 9 | (** [handle t e] updates the state machine [t] with the event [e] to give the resulting state machine in a new state and the list of actions to be performed *) 10 | val handle : t -> Events.t -> t * Actions.t list * Actions.handler_actions list 11 | 12 | val to_string : t -> string 13 | -------------------------------------------------------------------------------- /src/stream.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | | Header of Xml.tag 3 | | Features 4 | | Error 5 | | Close 6 | [@@deriving sexp] 7 | 8 | let to_string = function 9 | | Header tag -> Xml.tag_to_string ~empty:false tag 10 | | Features -> "features" 11 | | Error -> "error" 12 | | Close -> "" 13 | ;; 14 | 15 | let features_sasl_mechanisms = 16 | Xml.create 17 | (("stream", "features"), []) 18 | ~children: 19 | [ Xml.create 20 | (("", "mechanisms"), ["", Xml.Xmlns "urn:ietf:params:xml:ns:xmpp-sasl"]) 21 | ~children: 22 | [ Xml.create (("", "mechanism"), []) ~children:[Xml.Text "PLAIN"] 23 | ; Xml.create (("", "mechanism"), []) ~children:[Xml.Text "ANONYMOUS"] ] ] 24 | ;; 25 | 26 | let features = 27 | Xml.create 28 | (("stream", "features"), []) 29 | ~children: 30 | [Xml.create (("", "bind"), ["", Xml.Xmlns "urn:ietf:params:xml:ns:xmpp-bind"])] 31 | ;; 32 | 33 | let create_header 34 | ?(version = "1.0") 35 | ?(lang = "en") 36 | ?(xmlns = "jabber:client") 37 | ?(stream_ns = "http://etherx.jabber.org/streams") 38 | ?(attributes = []) 39 | ?ato 40 | ?from 41 | () = 42 | let attributes = 43 | match ato with Some v -> ("", Xml.To v) :: attributes | None -> attributes 44 | in 45 | let attributes = 46 | match from with Some v -> ("", Xml.From v) :: attributes | None -> attributes 47 | in 48 | ( ("stream", "stream") 49 | , [ "", Xml.Id (Stanza.gen_id ()) 50 | ; "", Xml.Version version 51 | ; "xml", Xml.Lang lang 52 | ; "", Xml.Xmlns xmlns 53 | ; "xmlns", Xml.Stream stream_ns ] 54 | @ attributes ) 55 | ;; 56 | -------------------------------------------------------------------------------- /src/stream.mli: -------------------------------------------------------------------------------- 1 | type t = 2 | | Header of Xml.tag 3 | | Features 4 | | Error 5 | | Close 6 | [@@deriving sexp] 7 | 8 | val to_string : t -> string 9 | val features_sasl_mechanisms : Xml.t 10 | val features : Xml.t 11 | 12 | val create_header : 13 | ?version:string 14 | -> ?lang:string 15 | -> ?xmlns:string 16 | -> ?stream_ns:string 17 | -> ?attributes:Xml.attribute list 18 | -> ?ato:Jid.t 19 | -> ?from:Jid.t 20 | -> unit 21 | -> Xml.tag 22 | -------------------------------------------------------------------------------- /src/utils.ml: -------------------------------------------------------------------------------- 1 | let mask_id s = 2 | match Astring.String.find_sub ~sub:"id='" s with 3 | | Some i -> 4 | (match Astring.String.find_sub ~start:(i + 4) ~sub:"'" s with 5 | | Some j -> 6 | Astring.String.with_index_range ~first:0 ~last:(i + 3) s 7 | ^ "" 8 | ^ Astring.String.with_index_range ~first:j s 9 | | None -> assert false) 10 | | None -> s 11 | ;; 12 | 13 | let option_to_string string_func = function 14 | | Some thing -> "Some: " ^ string_func thing 15 | | None -> "None" 16 | ;; 17 | -------------------------------------------------------------------------------- /src/utils.mli: -------------------------------------------------------------------------------- 1 | val mask_id : string -> string 2 | val option_to_string : ('a -> string) -> 'a option -> string 3 | -------------------------------------------------------------------------------- /src/xml.ml: -------------------------------------------------------------------------------- 1 | open Sexplib.Std 2 | 3 | type name = string * string [@@deriving sexp] 4 | 5 | type attribute_value = 6 | | From of Jid.t 7 | | To of Jid.t 8 | | Id of string 9 | | Jid of Jid.t 10 | | Xmlns of string 11 | | Type of string 12 | | Ver of string 13 | | Version of string 14 | | Lang of string 15 | | Stream of string 16 | | Name of string 17 | | Subscription of string 18 | | Mechanism of string 19 | | Other of string * string 20 | [@@deriving sexp] 21 | 22 | type attribute = string * attribute_value [@@deriving sexp] 23 | type tag = name * attribute list [@@deriving sexp] 24 | 25 | type t = 26 | | Text of string 27 | | Element of tag * t list 28 | [@@deriving sexp] 29 | 30 | let remove_prefixes_attribute (_prefix, value) = "", value 31 | 32 | let rec remove_prefixes = function 33 | | Element (((_prefix, name), attributes), children) -> 34 | Element 35 | ( (("", name), List.map remove_prefixes_attribute attributes) 36 | , List.map remove_prefixes children ) 37 | | Text _t as text -> text 38 | ;; 39 | 40 | let name_to_string (prefix, name) = if prefix <> "" then prefix ^ ":" ^ name else name 41 | 42 | let attribute_to_string (namespace, nameval) = 43 | (if namespace <> "" then namespace ^ ":" else "") 44 | ^ 45 | match nameval with 46 | | From jid -> "from='" ^ Jid.to_string jid ^ "'" 47 | | To jid -> "to='" ^ Jid.to_string jid ^ "'" 48 | | Id s -> "id='" ^ s ^ "'" 49 | | Jid jid -> "jid='" ^ Jid.to_string jid ^ "'" 50 | | Xmlns s -> "xmlns='" ^ s ^ "'" 51 | | Type s -> "type='" ^ s ^ "'" 52 | | Ver s -> "ver='" ^ s ^ "'" 53 | | Version s -> "version='" ^ s ^ "'" 54 | | Lang s -> "lang='" ^ s ^ "'" 55 | | Stream s -> "stream='" ^ s ^ "'" 56 | | Name s -> "name='" ^ s ^ "'" 57 | | Subscription s -> "subscription='" ^ s ^ "'" 58 | | Mechanism s -> "mechanism='" ^ s ^ "'" 59 | | Other (name, value) -> name ^ "='" ^ value ^ "'" 60 | ;; 61 | 62 | let tag_to_string ~empty (name, attributes) = 63 | let sep = " " in 64 | let attr_string = 65 | String.concat sep (List.map (fun a -> attribute_to_string a) attributes) 66 | in 67 | let name_string = name_to_string name in 68 | "<" 69 | ^ name_string 70 | ^ (if attr_string <> "" then sep ^ attr_string else "") 71 | ^ if empty then "/>" else ">" 72 | ;; 73 | 74 | let rec to_string = function 75 | | Text s -> s 76 | | Element (((name, _attributes) as tag), children) -> 77 | (match children with 78 | | [] -> tag_to_string ~empty:true tag 79 | | cs -> 80 | tag_to_string ~empty:false tag 81 | ^ String.concat "" (List.map (fun c -> to_string c) cs) 82 | ^ "") 85 | ;; 86 | 87 | let create ?(children = []) tag = Element (tag, children) 88 | -------------------------------------------------------------------------------- /src/xml.mli: -------------------------------------------------------------------------------- 1 | type name = string * string [@@deriving sexp] 2 | 3 | type attribute_value = 4 | | From of Jid.t 5 | | To of Jid.t 6 | | Id of string 7 | | Jid of Jid.t 8 | | Xmlns of string 9 | | Type of string 10 | | Ver of string 11 | | Version of string 12 | | Lang of string 13 | | Stream of string 14 | | Name of string 15 | | Subscription of string 16 | | Mechanism of string 17 | | Other of string * string 18 | [@@deriving sexp] 19 | 20 | type attribute = string * attribute_value [@@deriving sexp] 21 | type tag = name * attribute list [@@deriving sexp] 22 | 23 | type t = 24 | | Text of string 25 | | Element of tag * t list 26 | [@@deriving sexp] 27 | 28 | val remove_prefixes : t -> t 29 | val to_string : t -> string 30 | val tag_to_string : empty:bool -> tag -> string 31 | val create : ?children:t list -> tag -> t 32 | -------------------------------------------------------------------------------- /test/integration/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name integration) 3 | (libraries lwt lwt.unix mirage-xmpp) 4 | (inline_tests 5 | (flags -show-counts -strict)) 6 | (preprocess 7 | (pps ppx_expect lwt_ppx bisect_ppx -conditional))) 8 | -------------------------------------------------------------------------------- /test/integration/integration.ml: -------------------------------------------------------------------------------- 1 | let send ?(timeout = 10.) ?(host = "127.0.0.1") ?(port = 5222) str = 2 | let timeout_t = 3 | let%lwt () = Lwt_unix.sleep timeout in 4 | Lwt.return "Timeout" 5 | in 6 | let request = 7 | let addr = Unix.ADDR_INET (Unix.inet_addr_of_string host, port) in 8 | Lwt_io.( 9 | with_connection addr (fun (_i, o) -> 10 | let%lwt () = write o str in 11 | Lwt.return "Success" )) 12 | in 13 | let s = Lwt_main.run (Lwt.pick [request; timeout_t]) in 14 | print_endline s 15 | ;; 16 | 17 | let send_recv ?(timeout = 10.) ?(host = "127.0.0.1") ?(port = 5222) str_list = 18 | let timeout_t = 19 | let%lwt () = Lwt_unix.sleep timeout in 20 | Lwt.return "Timeout" 21 | in 22 | let request = 23 | let mask_id s = 24 | match Astring.String.find_sub ~sub:"id='" s with 25 | | Some i -> 26 | (match Astring.String.find_sub ~start:(i + 4) ~sub:"'" s with 27 | | Some j -> 28 | Astring.String.with_index_range ~first:0 ~last:(i + 3) s 29 | ^ "redacted_for_testing" 30 | ^ Astring.String.with_index_range ~first:j s 31 | | None -> assert false) 32 | | None -> s 33 | in 34 | let addr = Unix.ADDR_INET (Unix.inet_addr_of_string host, port) in 35 | Lwt_io.( 36 | with_connection addr (fun (i, o) -> 37 | let rec reader () = 38 | (* Repeatedly read data from the connection and print it *) 39 | try%lwt 40 | let%lwt s = read_line i in 41 | print_endline ("Receive:\n" ^ mask_id s); 42 | if s = "" then Lwt.return "Finished" else reader () 43 | with End_of_file -> Lwt.return "Didn't close the stream before exiting" 44 | in 45 | let rec writer = function 46 | (* Send all the data in the list to the server *) 47 | | [] -> Lwt.return "Finished" 48 | | x :: xs -> 49 | print_endline ("Send:\n" ^ x); 50 | let%lwt () = write o x in 51 | let%lwt () = Lwt_unix.sleep 0.1 in 52 | writer xs 53 | in 54 | Lwt.async (fun () -> writer str_list); 55 | reader () )) 56 | in 57 | let s = Lwt_main.run (Lwt.pick [request; timeout_t]) in 58 | print_endline s 59 | ;; 60 | 61 | let start_unikernel () = 62 | print_endline "Starting unikernel"; 63 | let command = 64 | Lwt_process.shell 65 | "cd ../../../../; mirage/xmpp --hostname=\"im.example.com\" -l \"debug\" > \ 66 | unikernel.log 2>&1" 67 | in 68 | let _process = Lwt_process.open_process_none command in 69 | Unix.sleepf 0.1 70 | ;; 71 | 72 | let stop_unikernel () = 73 | print_endline "Stopping unikernel"; 74 | send ~port:8081 "exit"; 75 | Unix.sleepf 0.2 76 | ;; 77 | 78 | let test_unikernel f = 79 | start_unikernel (); 80 | f (); 81 | stop_unikernel () 82 | ;; 83 | 84 | let%expect_test "start stop" = 85 | test_unikernel (fun () -> ()); 86 | [%expect {| 87 | Starting unikernel 88 | Stopping unikernel 89 | Success |}] 90 | ;; 91 | 92 | let%expect_test "open and close stream" = 93 | test_unikernel (fun () -> 94 | send_recv 95 | [ "" 98 | ; "" ] ); 99 | [%expect 100 | {| 101 | Starting unikernel 102 | Send: 103 | 104 | Receive: 105 | 106 | Receive: 107 | PLAINANONYMOUS 108 | Send: 109 | 110 | Receive: 111 | Unexpected stream close during sasl negotiation 112 | Didn't close the stream before exiting 113 | Stopping unikernel 114 | Success |}] 115 | ;; 116 | 117 | let%expect_test "open stream with iq bind" = 118 | test_unikernel (fun () -> 119 | send_recv 120 | [ "" 123 | ; "AGp1bGlldABwYXNzd29yZA==" 125 | ; "" 128 | ; "balcony" 130 | ; "" ] ); 131 | [%expect 132 | {| 133 | Starting unikernel 134 | Send: 135 | 136 | Receive: 137 | 138 | Receive: 139 | PLAINANONYMOUS 140 | Send: 141 | AGp1bGlldABwYXNzd29yZA== 142 | Receive: 143 | 144 | Send: 145 | 146 | Receive: 147 | 148 | Receive: 149 | 150 | Send: 151 | balcony 152 | Receive: 153 | juliet@im.example.com/balcony 154 | Send: 155 | 156 | Receive: 157 | 158 | Finished 159 | Stopping unikernel 160 | Success |}] 161 | ;; 162 | 163 | let%expect_test "open stream with iq bind and roster get without contacts" = 164 | test_unikernel (fun () -> 165 | send_recv 166 | [ "" 169 | ; "AGp1bGlldABwYXNzd29yZA==" 171 | ; "" 174 | ; "balcony" 176 | ; "" 178 | ; "" ] ); 179 | [%expect 180 | {| 181 | Starting unikernel 182 | Send: 183 | 184 | Receive: 185 | 186 | Receive: 187 | PLAINANONYMOUS 188 | Send: 189 | AGp1bGlldABwYXNzd29yZA== 190 | Receive: 191 | 192 | Send: 193 | 194 | Receive: 195 | 196 | Receive: 197 | 198 | Send: 199 | balcony 200 | Receive: 201 | juliet@im.example.com/balcony 202 | Send: 203 | 204 | Receive: 205 | 206 | Send: 207 | 208 | Receive: 209 | 210 | Finished 211 | Stopping unikernel 212 | Success |}] 213 | ;; 214 | 215 | let%expect_test "open stream with iq bind and roster get with contacts" = 216 | test_unikernel (fun () -> 217 | send_recv 218 | [ "" 221 | ; "AGp1bGlldABwYXNzd29yZA==" 223 | ; "" 226 | ; "balcony" 228 | ; "Servants" 231 | ; "" 233 | ; "" ] ); 234 | [%expect 235 | {| 236 | Starting unikernel 237 | Send: 238 | 239 | Receive: 240 | 241 | Receive: 242 | PLAINANONYMOUS 243 | Send: 244 | AGp1bGlldABwYXNzd29yZA== 245 | Receive: 246 | 247 | Send: 248 | 249 | Receive: 250 | 251 | Receive: 252 | 253 | Send: 254 | balcony 255 | Receive: 256 | juliet@im.example.com/balcony 257 | Send: 258 | Servants 259 | Receive: 260 | 261 | Receive: 262 | Servants 263 | Send: 264 | 265 | Receive: 266 | Servants 267 | Send: 268 | 269 | Receive: 270 | 271 | Finished 272 | Stopping unikernel 273 | Success |}] 274 | ;; 275 | -------------------------------------------------------------------------------- /test/performance/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name performance) 3 | (libraries lwt lwt.unix cmdliner astring jingoo re) 4 | (preprocess 5 | (pps lwt_ppx))) 6 | -------------------------------------------------------------------------------- /test/performance/performance.ml: -------------------------------------------------------------------------------- 1 | open Cmdliner 2 | 3 | let run_python_stats file = 4 | let%lwt () = Lwt_io.printl @@ "PYTHON: Running stats on file: " ^ file in 5 | let%lwt _ = Lwt_unix.system @@ "python test/performance/stats.py --save " ^ file in 6 | Lwt_io.printl "PYTHON: Finished stats" 7 | ;; 8 | 9 | let run_command_with_output command = 10 | let command = Lwt_process.shell command in 11 | let process = Lwt_process.open_process_in command in 12 | let rec get_lines () = 13 | match%lwt Lwt_io.read_line_opt process#stdout with 14 | | Some l -> 15 | let%lwt lines_after = get_lines () in 16 | Lwt.return ((string_of_float (Unix.gettimeofday ()) ^ " " ^ l) :: lines_after) 17 | | None -> Lwt.return_nil 18 | in 19 | get_lines () 20 | ;; 21 | 22 | let get_cpu_mem_docker container_name = 23 | let command = 24 | "docker stats --no-stream " 25 | ^ container_name 26 | ^ " | sed -n '2p' | awk '{gsub(/%/, \"\", $3); gsub(/%/, \"\", $7); printf \"%s \ 27 | %s\", $3, $7}'" 28 | in 29 | run_command_with_output command 30 | ;; 31 | 32 | let tsung file server_name = 33 | let tsung_command = Lwt_process.shell "tsung -f test/performance/tsung.xml start" in 34 | let tsung_process = Lwt_process.open_process_in tsung_command in 35 | let rec tsung_get_lines () = 36 | match%lwt Lwt_io.read_line_opt tsung_process#stdout with 37 | | Some l -> 38 | let%lwt () = Lwt_io.printl @@ "TSUNG: " ^ l in 39 | let%lwt lines_after = tsung_get_lines () in 40 | Lwt.return (l :: lines_after) 41 | | None -> Lwt.return_nil 42 | in 43 | let tsung_lines = ref [] in 44 | Lwt.async (fun () -> 45 | let%lwt tsung_output = tsung_get_lines () in 46 | tsung_lines := tsung_output; 47 | Lwt.return_unit ); 48 | let cpumem_lines = ref [] in 49 | let rec main_loop () = 50 | match tsung_process#state with 51 | | Running -> 52 | let%lwt logged_lines = get_cpu_mem_docker server_name in 53 | cpumem_lines := !cpumem_lines @ logged_lines; 54 | let%lwt () = Lwt_unix.sleep 1. in 55 | main_loop () 56 | | Exited _ -> Lwt.return_unit 57 | in 58 | let%lwt () = main_loop () in 59 | match%lwt tsung_process#status with 60 | | Unix.WEXITED 0 -> 61 | (* get the log file location *) 62 | let dump_time, dump_file = 63 | match 64 | List.filter 65 | (fun line -> Astring.String.is_prefix ~affix:"Log directory is:" line) 66 | !tsung_lines 67 | with 68 | | [line] -> 69 | (match Astring.String.cut ~sep:"/" line with 70 | | Some (_, path) -> 71 | ( (match Astring.String.cut ~rev:true ~sep:"/" path with 72 | | Some (_, datetime) -> datetime 73 | | None -> "") 74 | , "/" ^ path ^ "/tsung.dump" ) 75 | | None -> "", "") 76 | | _ -> "", "" 77 | in 78 | (* separate the input file to the name of the xml file *) 79 | let config_name = 80 | match Astring.String.cut ~rev:true ~sep:"/" file with 81 | | Some (_, filename) -> 82 | (* remove the file extension *) 83 | (match Astring.String.cut ~rev:true ~sep:"." filename with 84 | | Some (fname, _) -> fname 85 | | None -> filename) 86 | | None -> file 87 | in 88 | (* copy the dump file to a new location with servername, xml file and time to identify it: servername-xmlfile-time.dump *) 89 | let results_dir = 90 | "test/performance/results/" 91 | ^ String.concat "-" [server_name; config_name; dump_time] 92 | in 93 | let%lwt () = 94 | try%lwt Lwt_unix.mkdir "test/performance/results" 0o755 with Unix.Unix_error _ -> 95 | Lwt.return_unit 96 | in 97 | let%lwt () = 98 | try%lwt Lwt_unix.mkdir results_dir 0o755 with Unix.Unix_error _ -> Lwt.return_unit 99 | in 100 | let%lwt cpumem_file = Lwt_io.open_file ~mode:Output (results_dir ^ "/cpumem") in 101 | let%lwt () = 102 | Lwt_list.iter_s (fun line -> Lwt_io.write_line cpumem_file line) !cpumem_lines 103 | in 104 | let%lwt () = Lwt_io.close cpumem_file in 105 | let copied_dump = results_dir ^ "/dump" in 106 | let%lwt () = Lwt_unix.rename dump_file copied_dump in 107 | let%lwt () = Lwt_io.printl "TSUNG: Finished Tsung" in 108 | Lwt.return results_dir 109 | | _ -> Lwt.return "" 110 | ;; 111 | 112 | let test_docker image volume server_name file = 113 | let command = 114 | Lwt_process.shell 115 | @@ "docker run --rm --name " 116 | ^ server_name 117 | ^ " " 118 | ^ (if volume <> "" then "-v " ^ volume else "") 119 | ^ " -p 5222:5222 " 120 | ^ image 121 | in 122 | let%lwt () = Lwt_io.printl "DOCKER: Starting container" in 123 | let process = Lwt_process.open_process_in command in 124 | let rec get_lines () = 125 | match%lwt Lwt_io.read_line_opt process#stdout with 126 | | Some l -> 127 | let%lwt () = Lwt_io.printl @@ "DOCKER: " ^ l in 128 | get_lines () 129 | | None -> Lwt.return_unit 130 | in 131 | Lwt.async get_lines; 132 | let%lwt () = Lwt_unix.sleep 20. in 133 | let%lwt results_dir = tsung file server_name in 134 | let%lwt () = Lwt_io.printl "DOCKER: Stopping container" in 135 | let%lwt _ = Lwt_unix.system @@ "docker stop " ^ server_name in 136 | Lwt.return results_dir 137 | ;; 138 | 139 | let test_none server_name file = tsung file server_name 140 | 141 | type server = 142 | | Mirage 143 | | Ejabberd 144 | | Tigase 145 | | Prosody 146 | | None 147 | 148 | let server_to_string = function 149 | | Mirage -> "mirage" 150 | | Ejabberd -> "ejabberd" 151 | | Tigase -> "tigase" 152 | | Prosody -> "prosody" 153 | | None -> "none" 154 | ;; 155 | 156 | let mirage = "jeffas/mirage-xmpp" 157 | let ejabberd = "ejabberd/ecs" 158 | let tigase = "dictcp/tigase" 159 | let prosody = "prosody/prosody" 160 | 161 | let performance 162 | servers files load_duration load_duration_unit load_arrivalrate load_arrivalrate_unit 163 | = 164 | Lwt_main.run 165 | (let%lwt () = 166 | Lwt_io.printl 167 | @@ "Servers: " 168 | ^ String.concat ", " (List.map (fun server -> server_to_string server) servers) 169 | in 170 | let%lwt () = Lwt_io.printl @@ "Files: " ^ String.concat ", " files in 171 | let%lwt () = 172 | Lwt_io.printl 173 | @@ "Load duration: " 174 | ^ string_of_int load_duration 175 | ^ " " 176 | ^ load_duration_unit 177 | in 178 | let%lwt () = 179 | Lwt_io.printl 180 | @@ "Load arrivalrate: " 181 | ^ string_of_int load_arrivalrate 182 | ^ " per " 183 | ^ load_arrivalrate_unit 184 | in 185 | let files_length = List.length files in 186 | let run test_fn = 187 | Lwt_list.iteri_s 188 | (fun i file -> 189 | let%lwt () = 190 | Templates.make_template 191 | file 192 | load_duration 193 | load_duration_unit 194 | load_arrivalrate 195 | load_arrivalrate_unit 196 | in 197 | let%lwt results_dir = test_fn file in 198 | let%lwt () = run_python_stats results_dir in 199 | if i + 1 <> files_length then Lwt_unix.sleep 30. else Lwt.return_unit ) 200 | files 201 | in 202 | Lwt_list.iter_s 203 | (fun server -> 204 | match server with 205 | | Mirage -> run @@ test_docker mirage "" @@ server_to_string Mirage 206 | | Ejabberd -> 207 | run 208 | @@ test_docker 209 | ejabberd 210 | "$(pwd)/docker/ejabberd/ejabberd.yml:/home/ejabberd/conf/ejabberd.yml" 211 | @@ server_to_string Ejabberd 212 | | Tigase -> 213 | run 214 | @@ test_docker 215 | tigase 216 | "$(pwd)/docker/tigase/init.properties:/opt/tigase-server/etc/init.properties" 217 | @@ server_to_string Tigase 218 | | Prosody -> 219 | run 220 | @@ test_docker 221 | prosody 222 | "$(pwd)/docker/prosody/prosody.cfg.lua:/etc/prosody/prosody.cfg.lua" 223 | @@ server_to_string Prosody 224 | | None -> run @@ test_none @@ server_to_string None ) 225 | servers) 226 | ;; 227 | 228 | (* Command line parsing *) 229 | 230 | let servers = 231 | let doc = "Run performance tests against the MirageOS unikernel" in 232 | let mirage = Mirage, Arg.info ["m"; "mirage"] ~doc in 233 | let doc = "Run performance tests against the Ejabberd server" in 234 | let ejabberd = Ejabberd, Arg.info ["e"; "ejabberd"] ~doc in 235 | let doc = "Run performance tests against the Tigase server" in 236 | let tigase = Tigase, Arg.info ["t"; "tigase"] ~doc in 237 | let doc = "Run performance tests against the Prosody server" in 238 | let prosody = Prosody, Arg.info ["p"; "prosody"] ~doc in 239 | let doc = "No automated server creation, just run tsung" in 240 | let none = None, Arg.info ["n"; "none"] ~doc in 241 | Arg.(value & vflag_all [] [mirage; ejabberd; tigase; prosody; none]) 242 | ;; 243 | 244 | let files = 245 | let doc = "The xml files to run tsung with." in 246 | Arg.(value & pos_all file [] & info [] ~doc) 247 | ;; 248 | 249 | let load_duration = 250 | let doc = "The duration to run the tests for" in 251 | Arg.(value & opt int 1 & info ["ld"; "load-duration"] ~doc) 252 | ;; 253 | 254 | let load_duration_unit = 255 | let doc = "The unit (minute or second) for the load duration." in 256 | Arg.(value & opt string "minute" & info ["ldu"; "load-duration-unit"] ~doc) 257 | ;; 258 | 259 | let load_arrivalrate = 260 | let doc = "The arrivalrate of the users for the scenario." in 261 | Arg.(value & opt int 10 & info ["la"; "load-arrivalrate"] ~doc) 262 | ;; 263 | 264 | let load_arrivalrate_unit = 265 | let doc = "The unit (minute or second) for the arrivalrate of users." in 266 | Arg.(value & opt string "second" & info ["lau"; "load-arrivalrate-unit"] ~doc) 267 | ;; 268 | 269 | let cmd = 270 | let doc = "Run performance tests against a given target." in 271 | ( Term.( 272 | const performance 273 | $ servers 274 | $ files 275 | $ load_duration 276 | $ load_duration_unit 277 | $ load_arrivalrate 278 | $ load_arrivalrate_unit) 279 | , Term.info "performance" ~doc ~exits:Term.default_exits ) 280 | ;; 281 | 282 | let info = 283 | let doc = "Run the performance tests against a given target." in 284 | Term.info "performance" ~doc ~exits:Term.default_exits 285 | ;; 286 | 287 | let () = Term.exit @@ Term.eval cmd 288 | -------------------------------------------------------------------------------- /test/performance/stats.py: -------------------------------------------------------------------------------- 1 | import argparse 2 | import math 3 | import re 4 | import xml.etree.ElementTree as ET 5 | from collections import defaultdict 6 | from enum import Enum 7 | from pprint import pprint 8 | 9 | import matplotlib.pyplot as plt 10 | import numpy as np 11 | 12 | 13 | def parse_newclient(line): 14 | """NewClient: