├── .github └── workflows │ └── workflow.yml ├── .gitignore ├── ChangeLog ├── LICENSE ├── MAINTAINERS ├── Makefile ├── README.md ├── dune-project ├── examples ├── dune ├── example1.ml ├── example2.ml ├── example2_unix.ml ├── example_lwt_ssl.ml └── example_tls.ml ├── irc-client-lwt-ssl.opam ├── irc-client-lwt.opam ├── irc-client-tls.opam ├── irc-client-unix.opam ├── irc-client.opam ├── src ├── core │ ├── dune │ ├── irc_client.ml │ ├── irc_client.mli │ ├── irc_helpers.ml │ ├── irc_helpers.mli │ ├── irc_message.ml │ ├── irc_message.mli │ ├── irc_transport.ml │ └── irc_transport.mli ├── lwt │ ├── dune │ ├── irc_client_lwt.ml │ └── irc_client_lwt.mli ├── lwt_ssl │ ├── dune │ ├── irc_client_lwt_ssl.ml │ └── irc_client_lwt_ssl.mli ├── tls │ ├── dune │ ├── irc_client_tls.ml │ └── irc_client_tls.mli └── unix │ ├── dune │ ├── irc_client_unix.ml │ └── irc_client_unix.mli └── test ├── dune ├── test_helpers.ml ├── test_message.ml └── test_unit_main.ml /.github/workflows/workflow.yml: -------------------------------------------------------------------------------- 1 | name: Main workflow 2 | 3 | on: 4 | - pull_request 5 | - push 6 | 7 | jobs: 8 | build: 9 | strategy: 10 | fail-fast: false 11 | matrix: 12 | os: 13 | - macos-latest 14 | - ubuntu-latest 15 | ocaml-compiler: 16 | - 4.12.x 17 | - 4.11.x 18 | - 4.10.x 19 | - 4.9.x 20 | - 4.8.x 21 | 22 | runs-on: ${{ matrix.os }} 23 | 24 | steps: 25 | - run: brew install openssl 26 | if: matrix.os == 'macos-latest' 27 | 28 | - name: Checkout code 29 | uses: actions/checkout@v2 30 | 31 | - name: Use OCaml ${{ matrix.ocaml-compiler }} 32 | uses: ocaml/setup-ocaml@v2 33 | with: 34 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 35 | 36 | - run: opam install . --deps-only --with-doc --with-test 37 | 38 | - run: opam exec -- dune build 39 | 40 | - run: opam exec -- dune runtest 41 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.swp 2 | 3 | _build 4 | oUnit-anon.cache 5 | 6 | travis-coveralls.sh 7 | .coverage/ 8 | *.merlin 9 | *.install 10 | -------------------------------------------------------------------------------- /ChangeLog: -------------------------------------------------------------------------------- 1 | 0.7.1 (21-Feb-2023): 2 | * Fix logging type when requested nick is in use 3 | * Stop reconnection loop on raising Exit 4 | * irc-client-tls now depends on tls-lwt instead of tls.lwt 5 | 6 | 0.7.0 (15-Jun-2021): 7 | * Switch CI to github actions 8 | * Add support for SASL authentication 9 | * Optionally send a message with the QUIT command 10 | * Try appending _ to nick if nick is in use 11 | * Move from travis to github actions 12 | 13 | 0.6.2 (22-Sep-2019): 14 | * Convert to dune 15 | * Add lwt_ssl implementation 16 | 17 | 0.6.1 (01-Aug-2018): 18 | * Correctly send messages starting with a colon 19 | * Remove some unused code 20 | 21 | 0.6.0 (20-Jun-2018): 22 | * Convert to jbuilder 23 | * Split into multiple opam packages 24 | 25 | 0.5.4 (03-Dec-2017): 26 | * Fix error in constructing PING messages 27 | 28 | 0.5.3 (03-Dec-2017): 29 | * Support two parameters in PING commands 30 | * Copy PING parameters when responding with a PONG command 31 | 32 | 0.5.2 (29-Oct-2017): 33 | * Add hardcoded client name to pong messages 34 | 35 | 0.5.1 (05-Oct-2017): 36 | * Default to passive keepalive in irc-client.unix 37 | * Stop waiting indefinitely for welcome message on connection 38 | 39 | 0.5.0 (01-Jul-2017): 40 | * Use Unix.time for timeouts 41 | * Update server last seen time when any communication is received 42 | * Catch exceptions raised when sending pings 43 | 44 | 0.4.0 (04-Jan-2017): 45 | * Add experimental TLS support 46 | * Add active and passive keepalive support for Irc_client_lwt 47 | * Add passive keepalive support for Irc_client_unix 48 | * Add generic CLIENT module type to interface 49 | * Backwards-incompatible changes: 50 | * Use the result type instead of a polymorphic variant for Irc_message.or_error 51 | * Add unit argument to the listen function to handle new optional argument 52 | 53 | 0.3.2 (19-Sep-2016): 54 | * Answer pings while establishing connection 55 | 56 | 0.3.1 (27-Jun-2016): 57 | * Wait for RPL_WELCOME before returning from connect 58 | 59 | 0.3.0 (25-Sep-2015): 60 | * Backwards-incompatible changes to Irc_message.t 61 | * Some arguments made optional in Irc_client 62 | 63 | 0.2.1 (23-May-2015): 64 | * Use Bytes for compatibility with -safe-string 65 | 66 | 0.2.0 (28-Apr-2014): 67 | * Interface tidyup 68 | * Add connect_by_name which performs a DNS lookup on a supplied hostname 69 | * Add send_notice to send NOTICE commands 70 | 71 | 0.1.2 (11-Dec-2013): 72 | * Make Lwt an optional dependency 73 | * Switch build system to oasis 74 | 75 | 0.1.1 (25-Sep-2013): 76 | * conditially compile the Lwt package 77 | * tidy the string manipulation code 78 | 79 | 0.1.0 (30-Apr-2013): 80 | * first public release 81 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (C) 2013 John Else 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to deal 5 | in the Software without restriction, including without limitation the rights to 6 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies 7 | of the Software, and to permit persons to whom the Software is furnished to do 8 | so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in all 11 | copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 19 | SOFTWARE. 20 | -------------------------------------------------------------------------------- /MAINTAINERS: -------------------------------------------------------------------------------- 1 | How to submit changes to this project 2 | ===================================== 3 | 4 | Please submit changes as pull requests to the repository on github. 5 | Please ensure that all changes have descriptive commit comments and 6 | include a Signed-off-by: line. 7 | 8 | Maintainers list 9 | ---------------- 10 | 11 | * John Else 12 | 13 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | dune build @install --profile release 3 | 4 | doc: 5 | dune build @doc 6 | 7 | clean: 8 | dune clean 9 | 10 | test: 11 | dune runtest --force 12 | 13 | install: 14 | dune install 15 | 16 | uninstall: 17 | dune uninstall 18 | 19 | watch: 20 | @dune build @all --watch 21 | 22 | ARGS= 23 | 24 | example1: 25 | dune exec examples/$@.exe --profile release -- $(ARGS) 26 | 27 | example2: 28 | dune exec examples/$@.exe --profile release -- $(ARGS) 29 | 30 | example2_unix: 31 | dune exec examples/$@.exe --profile release -- $(ARGS) 32 | 33 | example_tls: 34 | dune exec examples/$@.exe --profile release -- $(ARGS) 35 | 36 | .PHONY: example1 example2 example2_unix example_tls test 37 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | IRC client library, supporting Lwt and Unix blocking IO. 2 | 3 | [![Build status](https://github.com/johnelse/ocaml-irc-client/actions/workflows/workflow.yml/badge.svg)](https://github.com/johnelse/ocaml-irc-client/actions) 4 | [![Coverage Status](https://coveralls.io/repos/johnelse/ocaml-irc-client/badge.svg?branch=master)](https://coveralls.io/r/johnelse/ocaml-irc-client?branch=master) 5 | [![API reference](https://img.shields.io/badge/docs-API_reference-blue.svg)](https://johnelse.github.io/ocaml-irc-client) 6 | 7 | Build dependencies 8 | ------------------ 9 | 10 | * [lwt](http://ocsigen.org/lwt/) (optional) 11 | * [dune](https://github.com/ocaml/dune) 12 | * [logs](https://github.com/dbuenzli/logs) 13 | 14 | To run tests: 15 | * [ounit](http://ounit.forge.ocamlcore.org/) 16 | 17 | The latest tagged version is available via [opam](http://opam.ocaml.org): `opam install irc-client` 18 | 19 | Usage 20 | ----- 21 | 22 | Simple bot which connects to a channel, sends a message, and then logs all 23 | messages in that channel to stdout: 24 | 25 | ```ocaml 26 | open Lwt 27 | module C = Irc_client_lwt 28 | 29 | let host = "localhost" 30 | let port = 6667 31 | let realname = "Demo IRC bot" 32 | let nick = "demoirc" 33 | let username = nick 34 | let channel = "#demo_irc" 35 | let message = "Hello, world! This is a test from ocaml-irc-client" 36 | 37 | let callback _connection result = 38 | let open Irc_message in 39 | match result with 40 | | Result.Ok msg -> 41 | Lwt_io.printf "Got message: %s\n" (to_string msg) 42 | | Result.Error e -> 43 | Lwt_io.printl e 44 | 45 | let lwt_main = 46 | Lwt_unix.gethostbyname host 47 | >>= fun he -> C.connect ~addr:(he.Lwt_unix.h_addr_list.(0)) 48 | ~port ~username ~mode:0 ~realname ~nick () 49 | >>= fun connection -> Lwt_io.printl "Connected" 50 | >>= fun () -> C.send_join ~connection ~channel 51 | >>= fun () -> C.send_privmsg ~connection ~target:channel ~message 52 | >>= fun () -> C.listen ~connection ~callback () 53 | >>= fun () -> C.send_quit ~connection 54 | 55 | let _ = Lwt_main.run lwt_main 56 | ``` 57 | 58 | Compile the above with: 59 | 60 | ``` 61 | ocamlfind ocamlopt -package irc-client.lwt -linkpkg code.ml 62 | ``` 63 | 64 | Alternatively, you can find it at `examples/example1.ml`; enable its compilation 65 | with `./configure --enable-examples --enable-lwt`. 66 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.6) 2 | -------------------------------------------------------------------------------- /examples/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name example1) 3 | (modules Example1) 4 | (libraries irc-client-lwt lwt.unix)) 5 | 6 | (executable 7 | (name example2) 8 | (modules Example2) 9 | (libraries irc-client-lwt lwt.unix)) 10 | 11 | (executable 12 | (name example2_unix) 13 | (modules Example2_unix) 14 | (libraries irc-client-unix)) 15 | 16 | (executable 17 | (name example_tls) 18 | (modules Example_tls) 19 | (libraries irc-client-tls)) 20 | 21 | (executable 22 | (name example_lwt_ssl) 23 | (modules Example_lwt_ssl) 24 | (libraries irc-client-lwt-ssl)) 25 | -------------------------------------------------------------------------------- /examples/example1.ml: -------------------------------------------------------------------------------- 1 | open Lwt 2 | module C = Irc_client_lwt 3 | 4 | let host = "localhost" 5 | let port = 6667 6 | let realname = "Demo IRC bot" 7 | let nick = "demoirc" 8 | let username = nick 9 | let channel = "#demo_irc" 10 | let message = "Hello, world! This is a test from ocaml-irc-client" 11 | 12 | let callback _connection result = 13 | let open Irc_message in 14 | match result with 15 | | Result.Ok msg -> 16 | Lwt_io.printf "Got message: %s\n" (to_string msg) 17 | | Result.Error e -> 18 | Lwt_io.printl e 19 | 20 | let lwt_main = 21 | Lwt_unix.gethostbyname host 22 | >>= fun he -> C.connect ~addr:(he.Lwt_unix.h_addr_list.(0)) 23 | ~port ~username ~mode:0 ~realname ~nick () 24 | >>= fun connection -> Lwt_io.printl "Connected" 25 | >>= fun () -> C.send_join ~connection ~channel 26 | >>= fun () -> C.send_privmsg ~connection ~target:channel ~message 27 | >>= fun () -> C.listen ~connection ~callback () 28 | >>= fun () -> C.send_quit ~connection () 29 | 30 | let _ = Lwt_main.run lwt_main 31 | 32 | (* ocamlfind ocamlopt -package irc-client.lwt -linkpkg code.ml *) 33 | -------------------------------------------------------------------------------- /examples/example2.ml: -------------------------------------------------------------------------------- 1 | open Lwt 2 | module C = Irc_client_lwt 3 | module M = Irc_message 4 | 5 | let host = ref "irc.freenode.net" 6 | let port = ref 6667 7 | let nick = ref "bobobobot" 8 | let channel = ref "#demo_irc" 9 | let message = "Hello, world! This is a test from ocaml-irc-client" 10 | 11 | let callback connection result = 12 | match result with 13 | | Result.Ok ({M.command=M.Other _ ; _}as msg) -> 14 | Lwt_io.printf "Got unknown message: %s\n" (M.to_string msg) 15 | >>= fun () -> Lwt_io.flush Lwt_io.stdout 16 | | Result.Ok ({M.command=M.PRIVMSG (target, data); _} as msg) -> 17 | Lwt_io.printf "Got message: %s\n" (M.to_string msg) 18 | >>= fun () -> Lwt_io.flush Lwt_io.stdout 19 | >>= fun () -> C.send_privmsg ~connection ~target ~message:("ack: " ^ data) 20 | | Result.Ok msg -> 21 | Lwt_io.printf "Got message: %s\n" (M.to_string msg) 22 | >>= fun () -> Lwt_io.flush Lwt_io.stdout 23 | | Result.Error e -> 24 | Lwt_io.printl e 25 | 26 | let lwt_main = 27 | C.set_log Lwt_io.printl; 28 | C.reconnect_loop 29 | ~after:30 30 | ~connect:(fun () -> 31 | Lwt_io.printl "Connecting..." >>= fun () -> 32 | C.connect_by_name ~server:!host ~port:!port ~nick:!nick () 33 | ) 34 | ~f:(fun connection -> 35 | Lwt_io.printl "Connected" >>= fun () -> 36 | Lwt_io.printl "send join msg" >>= fun () -> 37 | C.send_join ~connection ~channel:!channel >>= fun () -> 38 | C.send_privmsg ~connection ~target:!channel ~message 39 | ) 40 | ~callback 41 | () 42 | 43 | let options = Arg.align 44 | [ "-host", Arg.Set_string host, " set remove server host name" 45 | ; "-port", Arg.Set_int port, " set remote server port" 46 | ; "-chan", Arg.Set_string channel, " channel to join" 47 | ] 48 | 49 | let _ = 50 | Arg.parse options (fun _ -> ()) "example2 [options]"; 51 | Lwt_main.run lwt_main 52 | 53 | (* ocamlfind ocamlopt -package irc-client.lwt -linkpkg code.ml *) 54 | -------------------------------------------------------------------------------- /examples/example2_unix.ml: -------------------------------------------------------------------------------- 1 | module C = Irc_client_unix 2 | module M = Irc_message 3 | 4 | let host = ref "irc.freenode.net" 5 | let port = ref 6667 6 | let nick = ref "bobobobot" 7 | let channel = ref "#demo_irc" 8 | let message = "Hello, world! This is a test from ocaml-irc-client" 9 | 10 | let callback connection result = 11 | match result with 12 | | Result.Ok ({M.command=M.Other _ ; _}as msg) -> 13 | Printf.printf "Got unknown message: %s\n" (M.to_string msg); 14 | flush stdout; 15 | | Result.Ok ({M.command=M.PRIVMSG (target, data); _} as msg) -> 16 | Printf.printf "Got message: %s\n" (M.to_string msg); 17 | flush stdout; 18 | C.send_privmsg ~connection ~target ~message:("ack: " ^ data); 19 | | Result.Ok msg -> 20 | Printf.printf "Got message: %s\n" (M.to_string msg); 21 | flush stdout; 22 | | Result.Error e -> 23 | print_endline e 24 | 25 | let main () = 26 | C.set_log print_endline; 27 | C.reconnect_loop 28 | ~after:30 29 | ~connect:(fun () -> 30 | print_endline "Connecting..."; 31 | C.connect_by_name ~server:!host ~port:!port ~nick:!nick () 32 | ) 33 | ~f:(fun connection -> 34 | print_endline "Connected"; 35 | Printf.printf "send join msg for `%s`\n" !channel; 36 | C.send_join ~connection ~channel:!channel; 37 | C.send_privmsg ~connection ~target:!channel ~message 38 | ) 39 | ~callback 40 | () 41 | 42 | let options = Arg.align 43 | [ "-host", Arg.Set_string host, " set remove server host name" 44 | ; "-port", Arg.Set_int port, " set remote server port" 45 | ; "-chan", Arg.Set_string channel, " channel to join" 46 | ] 47 | 48 | let _ = 49 | Arg.parse options (fun _ -> ()) "example2 [options]"; 50 | main () 51 | 52 | (* ocamlfind ocamlopt -package irc-client.unix -linkpkg code.ml *) 53 | -------------------------------------------------------------------------------- /examples/example_lwt_ssl.ml: -------------------------------------------------------------------------------- 1 | open Lwt 2 | module C = Irc_client_lwt_ssl 3 | module M = Irc_message 4 | 5 | let host = ref "irc.libera.chat" 6 | let port = ref 6697 7 | let nick = ref "bobobobot" 8 | let channel = ref "#demo_irc" 9 | let check_certif = ref false 10 | let debug = ref false 11 | let message = "Hello, world! This is a test from ocaml-irc-client" 12 | 13 | let callback connection result = 14 | match result with 15 | | Result.Ok ({M.command=M.Other _ ; _}as msg) -> 16 | Lwt_io.printf "Got unknown message: %s\n" (M.to_string msg) 17 | >>= fun () -> Lwt_io.flush Lwt_io.stdout 18 | | Result.Ok ({M.command=M.PRIVMSG (target, data); _} as msg) -> 19 | Lwt_io.printf "Got message: %s\n" (M.to_string msg) 20 | >>= fun () -> Lwt_io.flush Lwt_io.stdout 21 | >>= fun () -> C.send_privmsg ~connection ~target ~message:("ack: " ^ data) 22 | | Result.Ok msg -> 23 | Lwt_io.printf "Got message: %s\n" (M.to_string msg) 24 | >>= fun () -> Lwt_io.flush Lwt_io.stdout 25 | | Result.Error e -> 26 | Lwt_io.printl e 27 | 28 | let lwt_main () = 29 | let config = C.Config.({default with check_certificate= !check_certif}) in 30 | let username, password, sasl = 31 | match Sys.getenv "USER", Sys.getenv "PASSWORD" with 32 | | u, p -> u, Some p, true 33 | | exception _ -> "ocaml-irc-client", None, false 34 | in 35 | C.reconnect_loop 36 | ~after:30 37 | ~connect:(fun () -> 38 | Lwt_io.printl "Connecting..." >>= fun () -> 39 | C.connect_by_name ~config ~username ?password ~sasl 40 | ~server:!host ~port:!port ~nick:!nick () 41 | ) 42 | ~f:(fun connection -> 43 | Lwt_io.printl "Connected" >>= fun () -> 44 | Lwt_io.printl "send join msg" >>= fun () -> 45 | C.send_join ~connection ~channel:!channel >>= fun () -> 46 | C.send_privmsg ~connection ~target:!channel ~message 47 | ) 48 | ~callback 49 | () 50 | 51 | let options = Arg.align 52 | [ "-host", Arg.Set_string host, " set remove server host name" 53 | ; "-port", Arg.Set_int port, " set remote server port" 54 | ; "-chan", Arg.Set_string channel, " channel to join" 55 | ; "-nick", Arg.Set_string nick, " nickname" 56 | ; "-check", Arg.Set check_certif, " check certificate" 57 | ; "-no-check", Arg.Clear check_certif, " do not check certificate" 58 | ; "-debug", Arg.Set debug, " enable debug" 59 | ] 60 | 61 | let () = 62 | Logs.set_reporter (Logs.format_reporter()); 63 | Arg.parse options (fun _ -> ()) 64 | "example.exe [options]\nif USER and PASSWORD env vars are set, uses SASL authentication"; 65 | Logs.set_level ~all:true (Some (if !debug then Logs.Debug else Logs.Info)); 66 | Lwt_main.run 67 | (Lwt.catch 68 | lwt_main 69 | (fun e -> 70 | Printf.printf "exception: %s\n" (Printexc.to_string e); exit 1)) 71 | 72 | (* ocamlfind ocamlopt -package irc-client.lwt -linkpkg code.ml *) 73 | 74 | -------------------------------------------------------------------------------- /examples/example_tls.ml: -------------------------------------------------------------------------------- 1 | open Lwt 2 | module C = Irc_client_tls 3 | module M = Irc_message 4 | 5 | let host = ref "irc.freenode.net" 6 | let port = ref 6697 7 | let nick = ref "bobobobot" 8 | let channel = ref "#demo_irc" 9 | let message = "Hello, world! This is a test from ocaml-irc-client" 10 | 11 | let callback connection result = 12 | match result with 13 | | Result.Ok ({M.command=M.Other _ ; _}as msg) -> 14 | Lwt_io.printf "Got unknown message: %s\n" (M.to_string msg) 15 | >>= fun () -> Lwt_io.flush Lwt_io.stdout 16 | | Result.Ok ({M.command=M.PRIVMSG (target, data); _} as msg) -> 17 | Lwt_io.printf "Got message: %s\n" (M.to_string msg) 18 | >>= fun () -> Lwt_io.flush Lwt_io.stdout 19 | >>= fun () -> C.send_privmsg ~connection ~target ~message:("ack: " ^ data) 20 | | Result.Ok msg -> 21 | Lwt_io.printf "Got message: %s\n" (M.to_string msg) 22 | >>= fun () -> Lwt_io.flush Lwt_io.stdout 23 | | Result.Error e -> 24 | Lwt_io.printl e 25 | 26 | let lwt_main () = 27 | C.set_log Lwt_io.printl; 28 | C.reconnect_loop 29 | ~after:30 30 | ~connect:(fun () -> 31 | Lwt_io.printl "Connecting..." >>= fun () -> 32 | C.connect_by_name ~server:!host ~port:!port ~nick:!nick () 33 | ) 34 | ~f:(fun connection -> 35 | Lwt_io.printl "Connected" >>= fun () -> 36 | Lwt_io.printl "send join msg" >>= fun () -> 37 | C.send_join ~connection ~channel:!channel >>= fun () -> 38 | C.send_privmsg ~connection ~target:!channel ~message 39 | ) 40 | ~callback 41 | () 42 | 43 | let options = Arg.align 44 | [ "-host", Arg.Set_string host, " set remove server host name" 45 | ; "-port", Arg.Set_int port, " set remote server port" 46 | ; "-chan", Arg.Set_string channel, " channel to join" 47 | ] 48 | 49 | let _ = 50 | Arg.parse options (fun _ -> ()) "example2 [options]"; 51 | Lwt_main.run 52 | (Lwt.catch 53 | lwt_main 54 | (fun e -> 55 | Printf.printf "exception: %s\n" (Printexc.to_string e); exit 1)) 56 | 57 | (* ocamlfind ocamlopt -package irc-client.lwt -linkpkg code.ml *) 58 | 59 | -------------------------------------------------------------------------------- /irc-client-lwt-ssl.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | authors: ["Simon Cruanes"] 3 | homepage: "https://github.com/johnelse/ocaml-irc-client" 4 | bug-reports: "https://github.com/johnelse/ocaml-irc-client/issues" 5 | dev-repo: "git://github.com/johnelse/ocaml-irc-client" 6 | maintainer: "john.else@gmail.com" 7 | synopsis: "IRC client library, supporting Lwt and Unix blocking IO" 8 | build: [ 9 | ["dune" "build" "@install" "-p" name "-j" jobs] 10 | ["dune" "build" "@doc" "-p" name "-j" jobs] {with-doc} 11 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 12 | ] 13 | depends: [ 14 | "dune" {>= "1.6"} 15 | "irc-client" 16 | "lwt" 17 | "lwt_ssl" 18 | "odoc" {with-doc} 19 | "ocaml" { >= "4.02.0" } 20 | "ssl" { >= "0.5.8" } 21 | ] 22 | -------------------------------------------------------------------------------- /irc-client-lwt.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | authors: ["John Else" "Simon Cruanes"] 3 | homepage: "https://github.com/johnelse/ocaml-irc-client" 4 | bug-reports: "https://github.com/johnelse/ocaml-irc-client/issues" 5 | dev-repo: "git://github.com/johnelse/ocaml-irc-client" 6 | maintainer: "john.else@gmail.com" 7 | synopsis: "IRC client library, supporting Lwt and Unix blocking IO" 8 | build: [ 9 | ["dune" "build" "@install" "-p" name "-j" jobs] 10 | ["dune" "build" "@doc" "-p" name "-j" jobs] {with-doc} 11 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 12 | ] 13 | depends: [ 14 | "dune" {>= "1.6"} 15 | "irc-client" 16 | "lwt" 17 | "odoc" {with-doc} 18 | "ocaml" { >= "4.02.0" } 19 | ] 20 | -------------------------------------------------------------------------------- /irc-client-tls.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | authors: ["John Else" "Simon Cruanes"] 3 | homepage: "https://github.com/johnelse/ocaml-irc-client" 4 | bug-reports: "https://github.com/johnelse/ocaml-irc-client/issues" 5 | dev-repo: "git://github.com/johnelse/ocaml-irc-client" 6 | maintainer: "john.else@gmail.com" 7 | synopsis: "IRC client library, supporting Lwt and Unix blocking IO" 8 | build: [ 9 | ["dune" "build" "@install" "-p" name "-j" jobs] 10 | ["dune" "build" "@doc" "-p" name "-j" jobs] {with-doc} 11 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 12 | ] 13 | depends: [ 14 | "dune" {>= "1.6"} 15 | "irc-client" 16 | "lwt" 17 | "tls-lwt" {>= "0.16.0"} 18 | "odoc" {with-doc} 19 | "ocaml" { >= "4.02.0" } 20 | ] 21 | -------------------------------------------------------------------------------- /irc-client-unix.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | authors: ["John Else" "Simon Cruanes"] 3 | homepage: "https://github.com/johnelse/ocaml-irc-client" 4 | bug-reports: "https://github.com/johnelse/ocaml-irc-client/issues" 5 | dev-repo: "git://github.com/johnelse/ocaml-irc-client" 6 | maintainer: "john.else@gmail.com" 7 | synopsis: "IRC client library, supporting Lwt and Unix blocking IO" 8 | build: [ 9 | ["dune" "build" "@install" "-p" name "-j" jobs] 10 | ["dune" "build" "@doc" "-p" name "-j" jobs] {with-doc} 11 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 12 | ] 13 | depends: [ 14 | "dune" {>= "1.6"} 15 | "base-unix" 16 | "irc-client" 17 | "odoc" {with-doc} 18 | "ocaml" { >= "4.02.0" } 19 | ] 20 | -------------------------------------------------------------------------------- /irc-client.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | authors: ["John Else" "Simon Cruanes"] 3 | homepage: "https://github.com/johnelse/ocaml-irc-client" 4 | bug-reports: "https://github.com/johnelse/ocaml-irc-client/issues" 5 | dev-repo: "git://github.com/johnelse/ocaml-irc-client" 6 | maintainer: "john.else@gmail.com" 7 | synopsis: "IRC client library, supporting Lwt and Unix blocking IO" 8 | build: [ 9 | ["dune" "build" "@install" "-p" name "-j" jobs] 10 | ["dune" "build" "@doc" "-p" name "-j" jobs] {with-doc} 11 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 12 | ] 13 | depends: [ 14 | "dune" {>= "1.6"} 15 | "base-bytes" 16 | "result" 17 | "logs" 18 | "base64" {>= "3.0.0"} 19 | "ounit" {with-test} 20 | "odoc" {with-doc} 21 | "ocaml" { >= "4.02.0" } 22 | ] 23 | -------------------------------------------------------------------------------- /src/core/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name irc_client) 3 | (public_name irc-client) 4 | (wrapped false) 5 | (libraries result bytes logs base64)) 6 | -------------------------------------------------------------------------------- /src/core/irc_client.ml: -------------------------------------------------------------------------------- 1 | module Log = Irc_helpers.Log 2 | 3 | module type CLIENT = sig 4 | module Io : sig 5 | type 'a t 6 | type inet_addr 7 | type config 8 | end 9 | 10 | type connection_t 11 | 12 | val send : connection:connection_t -> Irc_message.t -> unit Io.t 13 | (** Send the given message *) 14 | 15 | val send_join : connection:connection_t -> channel:string -> unit Io.t 16 | (** Send the JOIN command. *) 17 | 18 | val send_nick : connection:connection_t -> nick:string -> unit Io.t 19 | (** Send the NICK command. *) 20 | 21 | val send_pass : connection:connection_t -> password:string -> unit Io.t 22 | (** Send the PASS command. *) 23 | 24 | val send_pong : connection:connection_t -> 25 | message1:string -> message2:string -> unit Io.t 26 | (** Send the PONG command. *) 27 | 28 | val send_privmsg : connection:connection_t -> 29 | target:string -> message:string -> unit Io.t 30 | (** Send the PRIVMSG command. *) 31 | 32 | val send_notice : connection:connection_t -> 33 | target:string -> message:string -> unit Io.t 34 | (** Send the NOTICE command. *) 35 | 36 | val send_quit : ?msg:string -> connection:connection_t -> unit -> unit Io.t 37 | (** Send the QUIT command. *) 38 | 39 | val send_user : connection:connection_t -> 40 | username:string -> mode:int -> realname:string -> unit Io.t 41 | (** Send the USER command. *) 42 | 43 | val connect : 44 | ?username:string -> ?mode:int -> ?realname:string -> ?password:string -> 45 | ?sasl:bool -> ?config:Io.config -> 46 | addr:Io.inet_addr -> port:int -> nick:string -> unit -> 47 | connection_t Io.t 48 | (** Connect to an IRC server at address [addr]. The PASS command will be 49 | sent if [password] is not None. *) 50 | 51 | val connect_by_name : 52 | ?username:string -> ?mode:int -> ?realname:string -> ?password:string -> 53 | ?sasl:bool -> ?config:Io.config -> 54 | server:string -> port:int -> nick:string -> unit -> 55 | connection_t option Io.t 56 | (** Try to resolve the [server] name using DNS, otherwise behaves like 57 | {!connect}. Returns [None] if no IP could be found for the given 58 | name. See {!connect} for more details. *) 59 | 60 | (** Information on keeping the connection alive *) 61 | type keepalive = { 62 | mode: [`Active | `Passive]; 63 | timeout: int; 64 | } 65 | 66 | val default_keepalive : keepalive 67 | (** Default value for keepalive: active mode with auto-reconnect *) 68 | 69 | val listen : 70 | ?keepalive:keepalive -> 71 | connection:connection_t -> 72 | callback:( 73 | connection_t -> 74 | Irc_message.parse_result -> 75 | unit Io.t) -> 76 | unit -> 77 | unit Io.t 78 | (** [listen connection callback] listens for incoming messages on 79 | [connection]. All server pings are handled internally; all other 80 | messages are passed, along with [connection], to [callback]. 81 | @param keepalive the behavior on disconnection (if the transport 82 | supports {!Irc_transport.IO.pick} and {!Irc_transport.IO.sleep}) *) 83 | 84 | val reconnect_loop : 85 | ?keepalive:keepalive -> 86 | ?reconnect:bool -> 87 | after:int -> 88 | connect:(unit -> connection_t option Io.t) -> 89 | f:(connection_t -> unit Io.t) -> 90 | callback:( 91 | connection_t -> 92 | Irc_message.parse_result -> 93 | unit Io.t) -> 94 | unit -> 95 | unit Io.t 96 | (** A combination of {!connect} and {!listen} that, every time 97 | the connection is terminated, tries to start a new one 98 | after [after] seconds. 99 | @param after time before trying to reconnect 100 | @param connect how to reconnect 101 | (a closure over {!connect} or {!connect_by_name}) 102 | @param callback the callback for {!listen} 103 | @param f the function to call after connection *) 104 | end 105 | 106 | module Make(Io: Irc_transport.IO) = struct 107 | module Io = Io 108 | 109 | type connection_t = { 110 | sock: Io.file_descr; 111 | buffer: Buffer.t; 112 | read_length: int; 113 | read_data: Bytes.t; (* for reading *) 114 | lines: string Queue.t; (* lines read so far *) 115 | mutable terminated: bool; 116 | } 117 | 118 | open Io 119 | 120 | let rec really_write ~connection ~data ~offset ~length = 121 | if length = 0 then return () else 122 | Io.write connection.sock data offset length 123 | >>= (fun chars_written -> 124 | really_write ~connection ~data 125 | ~offset:(offset + chars_written) 126 | ~length:(length - chars_written)) 127 | 128 | let send_raw ~connection ~data = 129 | Log.debug (fun k->k"send: %s" data); 130 | let formatted_data = Bytes.unsafe_of_string (Printf.sprintf "%s\r\n" data) in 131 | let length = Bytes.length formatted_data in 132 | really_write ~connection ~data:formatted_data ~offset:0 ~length 133 | 134 | module M = Irc_message 135 | 136 | let send ~connection msg = 137 | send_raw ~connection ~data:(M.to_string msg) 138 | 139 | let send_join ~connection ~channel = 140 | send ~connection (M.join ~chans:[channel] ~keys:None) 141 | 142 | let send_nick ~connection ~nick = 143 | send ~connection (M.nick nick) 144 | 145 | let send_auth_sasl ~connection ~user ~password = 146 | Log.debug (fun k->k"login using SASL with user=%S" user); 147 | send_raw ~connection ~data:"CAP REQ :sasl" >>= fun () -> 148 | send_raw ~connection ~data:"AUTHENTICATE PLAIN" >>= fun () -> 149 | let b64_login = 150 | Base64.encode_string @@ 151 | Printf.sprintf "%s\x00%s\x00%s" user user password 152 | in 153 | let data = Printf.sprintf "AUTHENTICATE %s" b64_login in 154 | send_raw ~connection ~data 155 | 156 | let send_pass ~connection ~password = 157 | send ~connection (M.pass password) 158 | 159 | let send_ping ~connection ~message1 ~message2 = 160 | send ~connection (M.ping ~message1 ~message2) 161 | 162 | let send_pong ~connection ~message1 ~message2 = 163 | send ~connection (M.pong ~message1 ~message2) 164 | 165 | let send_privmsg ~connection ~target ~message = 166 | send ~connection (M.privmsg ~target message) 167 | 168 | let send_notice ~connection ~target ~message = 169 | send ~connection (M.notice ~target message) 170 | 171 | let send_quit ?(msg="") ~connection () = 172 | send ~connection (M.quit ~msg) 173 | 174 | let send_user ~connection ~username ~mode ~realname = 175 | let msg = M.user ~username ~mode ~realname in 176 | send ~connection msg 177 | 178 | let mk_connection_ sock = 179 | let read_length = 1024 in 180 | { 181 | sock = sock; 182 | buffer = Buffer.create 128; 183 | read_length; 184 | read_data = Bytes.make read_length ' '; 185 | lines = Queue.create (); 186 | terminated = false; 187 | } 188 | 189 | type 'a input_res = 190 | | Read of 'a 191 | | Timeout 192 | | End 193 | 194 | let rec next_line_ ~timeout ~connection:c : string input_res Io.t = 195 | if c.terminated 196 | then return End 197 | else if Queue.length c.lines > 0 198 | then return (Read (Queue.pop c.lines)) 199 | else begin 200 | (* Read some data into our string. *) 201 | Io.read_with_timeout ~timeout c.sock c.read_data 0 c.read_length 202 | >>= function 203 | | None -> return Timeout 204 | | Some 0 -> 205 | c.terminated <- true; 206 | return End (* EOF from server - we have quit or been kicked. *) 207 | | Some len -> 208 | (* read some data, push lines into [c.lines] (if any) *) 209 | let input = Bytes.sub_string c.read_data 0 len in 210 | let lines = Irc_helpers.handle_input ~buffer:c.buffer ~input in 211 | List.iter (fun l -> Queue.push l c.lines) lines; 212 | next_line_ ~timeout ~connection:c 213 | end 214 | 215 | type nick_retry = { 216 | mutable nick: string; 217 | mutable tries: int; 218 | } 219 | 220 | let welcome_timeout = 30. 221 | let max_nick_retries = 3 222 | 223 | let wait_for_welcome ~start ~connection ~nick = 224 | let nick_try = { 225 | nick = nick; 226 | tries = 1 227 | } in 228 | let rec aux () = 229 | let now = Io.time () in 230 | let timeout = start +. welcome_timeout -. now in 231 | if timeout < 0.5 then return () 232 | else begin 233 | if nick_try.tries > max_nick_retries then return () 234 | else begin 235 | (* wait a bit more *) 236 | let timeout = int_of_float (ceil timeout) in 237 | assert (timeout > 0); 238 | (* logf "wait for welcome message (%ds)" timeout >>= fun () -> *) 239 | next_line_ ~timeout ~connection 240 | >>= function 241 | | Timeout 242 | | End -> return () 243 | | Read line -> 244 | Log.debug (fun k->k"read: %s" line); 245 | begin match M.parse line with 246 | | Result.Ok {M.command = M.Other ("001", _); _} -> 247 | (* we received "RPL_WELCOME", i.e. 001 *) 248 | return () 249 | | Result.Ok {M.command = M.PING (message1, message2); _} -> 250 | (* server may ask for ping at any time *) 251 | send_pong ~connection ~message1 ~message2 >>= aux 252 | | Result.Ok {M.command = M.Other ("433", _); _} -> 253 | (* we received "ERR_NICKNAMEINUSE" *) 254 | nick_try.nick <- nick_try.nick ^ "_"; 255 | nick_try.tries <- nick_try.tries + 1; 256 | Log.err (fun k->k"Nick name already in use, trying %s" nick_try.nick); 257 | send_nick ~connection ~nick:nick_try.nick >>= aux 258 | | _ -> aux () 259 | end 260 | end 261 | end 262 | in 263 | aux () >|= fun () -> 264 | Log.info (fun k->k"finished waiting for welcome msg") 265 | 266 | let connect 267 | ?username ?(mode=0) ?(realname="irc-client") 268 | ?password ?(sasl=true) ?config ~addr ~port ~nick () = 269 | Io.open_socket ?config addr port >>= (fun sock -> 270 | let connection = mk_connection_ sock in 271 | 272 | let cap_end = ref false in 273 | begin 274 | match username, password with 275 | | Some user, Some password when sasl -> 276 | cap_end := true; 277 | send_auth_sasl ~connection ~user ~password 278 | | _, Some password -> send_pass ~connection ~password 279 | | _ -> return () 280 | end 281 | >>= fun () -> 282 | let username = match username with Some u -> u | None -> "ocaml-irc-client" in 283 | send_nick ~connection ~nick 284 | >>= fun () -> send_user ~connection ~username ~mode ~realname 285 | >>= fun () -> 286 | begin 287 | if !cap_end then send_raw ~connection ~data:"CAP END" else return() 288 | end 289 | >>= fun () -> wait_for_welcome ~start:(Io.time ()) ~connection ~nick 290 | >>= fun () -> return connection) 291 | 292 | let connect_by_name 293 | ?(username="irc-client") ?(mode=0) ?(realname="irc-client") 294 | ?password ?sasl ?config ~server ~port ~nick () = 295 | Io.gethostbyname server 296 | >>= (function 297 | | [] -> Io.return None 298 | | addr :: _ -> 299 | connect ~addr ~port ~username ~mode ~realname ~nick ?password ?sasl ?config () 300 | >>= fun connection -> Io.return (Some connection)) 301 | 302 | (** Information on keeping the connection alive *) 303 | type keepalive = { 304 | mode: [`Active | `Passive]; 305 | timeout: int; 306 | } 307 | 308 | let default_keepalive: keepalive = { 309 | mode = `Active; 310 | timeout = 60; 311 | } 312 | 313 | type listen_keepalive_state = { 314 | mutable last_seen: float; 315 | mutable last_active_ping: float; 316 | mutable finished: bool; 317 | } 318 | 319 | (* main loop for pinging server actively *) 320 | let active_ping_thread keepalive state ~connection = 321 | let rec loop () = 322 | assert (keepalive.mode = `Active); 323 | let now = Io.time () in 324 | let time_til_ping = 325 | (max state.last_active_ping state.last_seen) 326 | +. (float keepalive.timeout /. 2.) -. now 327 | in 328 | if state.finished 329 | then Io.return () 330 | else begin 331 | (* send "ping" if active mode and it's been long enough *) 332 | if time_til_ping < 0. then ( 333 | state.last_active_ping <- now; 334 | Log.debug (fun k->k"send ping to server..."); 335 | (* try to send a ping, but ignore errors *) 336 | Io.catch 337 | (fun () -> send_ping ~connection ~message1:"ping" ~message2:"") 338 | (fun _ -> Io.return ()) 339 | ) else ( 340 | Io.return () 341 | ) 342 | >>= fun () -> 343 | (* sleep until the due date, then check again *) 344 | Io.sleep (int_of_float time_til_ping + 1) 345 | end 346 | >>= fun () -> loop () 347 | in 348 | loop () 349 | 350 | let listen ?(keepalive=default_keepalive) ~connection ~callback () = 351 | (* main loop *) 352 | let rec listen_rec state = 353 | let now = Io.time () in 354 | let timeout = state.last_seen +. float keepalive.timeout -. now in 355 | next_line_ ~timeout:(int_of_float (ceil timeout)) ~connection 356 | >>= function 357 | | Timeout -> 358 | state.finished <- true; 359 | Log.info (fun k->k"client timeout"); 360 | Io.return () 361 | | End -> 362 | state.finished <- true; 363 | Log.info (fun k->k"connection closed"); 364 | Io.return () 365 | | Read line -> 366 | (* update "last_seen" field *) 367 | Log.debug (fun k->k"read: %s" line); 368 | let now = Io.time() in 369 | state.last_seen <- max now state.last_seen; 370 | begin match M.parse line with 371 | | Result.Ok {M.command = M.PING (message1, message2); _} -> 372 | (* Handle pings without calling the callback. *) 373 | Log.debug (fun k->k"reply pong to server"); 374 | send_pong ~connection ~message1 ~message2 375 | | Result.Ok {M.command = M.PONG _; _} -> 376 | (* active response from server *) 377 | Io.return () 378 | | result -> callback connection result 379 | end 380 | >>= fun () -> 381 | if state.finished 382 | then Io.return () 383 | else listen_rec state 384 | in 385 | let state = { 386 | last_seen = Io.time(); 387 | last_active_ping = Io.time(); 388 | finished = false; 389 | } in 390 | (* connect, serve, etc. *) 391 | begin match Io.pick with 392 | | Some pick when keepalive.mode = `Active -> 393 | pick [ 394 | listen_rec state; 395 | active_ping_thread keepalive state ~connection; 396 | ] 397 | | _ -> 398 | listen_rec state 399 | end 400 | 401 | let reconnect_loop ?keepalive ?(reconnect=true) ~after ~connect ~f ~callback () = 402 | let rec aux () = 403 | Io.catch 404 | (fun () -> 405 | connect () >>= function 406 | | None -> Log.info (fun k->k"could not connect"); return true 407 | | Some connection -> 408 | f connection >>= fun () -> 409 | listen ?keepalive ~connection ~callback () >>= fun () -> 410 | Log.info (fun k->k"connection terminated."); 411 | return reconnect) 412 | (function 413 | | Exit -> 414 | Log.info (fun k->k"stopping the connection loop"); 415 | return false 416 | | e -> 417 | Log.err (fun k->k"reconnect_loop: exception %s" (Printexc.to_string e)); 418 | return true) 419 | >>= fun loop -> 420 | (* wait and reconnect *) 421 | Io.sleep after >>= fun () -> 422 | if loop then ( 423 | Log.info (fun k->k"try to reconnect..."); 424 | aux() 425 | ) else return () 426 | in 427 | aux () 428 | end 429 | -------------------------------------------------------------------------------- /src/core/irc_client.mli: -------------------------------------------------------------------------------- 1 | (** Generic IRC client library, functorised over the 2 | {{:Irc_transport.IO.html}Irc_transport.IO} module. *) 3 | 4 | module type CLIENT = sig 5 | module Io : sig 6 | type 'a t 7 | type inet_addr 8 | type config 9 | end 10 | 11 | type connection_t 12 | 13 | val send : connection:connection_t -> Irc_message.t -> unit Io.t 14 | (** Send the given message *) 15 | 16 | val send_join : connection:connection_t -> channel:string -> unit Io.t 17 | (** Send the JOIN command. *) 18 | 19 | val send_nick : connection:connection_t -> nick:string -> unit Io.t 20 | (** Send the NICK command. *) 21 | 22 | val send_pass : connection:connection_t -> password:string -> unit Io.t 23 | (** Send the PASS command. *) 24 | 25 | val send_pong : connection:connection_t -> 26 | message1:string -> message2:string -> unit Io.t 27 | (** Send the PONG command. *) 28 | 29 | val send_privmsg : connection:connection_t -> 30 | target:string -> message:string -> unit Io.t 31 | (** Send the PRIVMSG command. *) 32 | 33 | val send_notice : connection:connection_t -> 34 | target:string -> message:string -> unit Io.t 35 | (** Send the NOTICE command. *) 36 | 37 | val send_quit : ?msg:string -> connection:connection_t -> unit -> unit Io.t 38 | (** Send the QUIT command. *) 39 | 40 | val send_user : connection:connection_t -> 41 | username:string -> mode:int -> realname:string -> unit Io.t 42 | (** Send the USER command. *) 43 | 44 | val connect : 45 | ?username:string -> ?mode:int -> ?realname:string -> ?password:string -> 46 | ?sasl:bool -> ?config:Io.config -> 47 | addr:Io.inet_addr -> port:int -> nick:string -> unit -> 48 | connection_t Io.t 49 | (** Connect to an IRC server at address [addr]. The PASS command will be 50 | sent if [password] is not None and if [sasl] is [false]. 51 | @param sasl if true, try to use SASL (plain) authentication with the server. 52 | This is an IRCv3 extension and might not be supported everywhere; it 53 | might also require a secure transport (see {!Irc_client_lwt_ssl} 54 | or {!Irc_client_tls} for example). This param exists @since 0.7. 55 | *) 56 | 57 | val connect_by_name : 58 | ?username:string -> ?mode:int -> ?realname:string -> ?password:string -> 59 | ?sasl:bool -> ?config:Io.config -> 60 | server:string -> port:int -> nick:string -> unit -> 61 | connection_t option Io.t 62 | (** Try to resolve the [server] name using DNS, otherwise behaves like 63 | {!connect}. Returns [None] if no IP could be found for the given 64 | name. See {!connect} for more details. *) 65 | 66 | (** Information on keeping the connection alive *) 67 | type keepalive = { 68 | mode: [`Active | `Passive]; 69 | timeout: int; 70 | } 71 | 72 | val default_keepalive : keepalive 73 | (** Default value for keepalive: active mode with auto-reconnect *) 74 | 75 | val listen : 76 | ?keepalive:keepalive -> 77 | connection:connection_t -> 78 | callback:( 79 | connection_t -> 80 | Irc_message.parse_result -> 81 | unit Io.t) -> 82 | unit -> 83 | unit Io.t 84 | (** [listen connection callback] listens for incoming messages on 85 | [connection]. All server pings are handled internally; all other 86 | messages are passed, along with [connection], to [callback]. 87 | @param keepalive the behavior on disconnection (if the transport 88 | supports {!Irc_transport.IO.pick} and {!Irc_transport.IO.sleep}) *) 89 | 90 | val reconnect_loop : 91 | ?keepalive:keepalive -> 92 | ?reconnect:bool -> 93 | after:int -> 94 | connect:(unit -> connection_t option Io.t) -> 95 | f:(connection_t -> unit Io.t) -> 96 | callback:( 97 | connection_t -> 98 | Irc_message.parse_result -> 99 | unit Io.t) -> 100 | unit -> 101 | unit Io.t 102 | (** A combination of {!connect} and {!listen} that, every time 103 | the connection is terminated, tries to start a new one 104 | after [after] seconds. It stops reconnecting if the exception 105 | [Exit] is raised. 106 | @param after time before trying to reconnect 107 | @param connect how to reconnect 108 | (a closure over {!connect} or {!connect_by_name}) 109 | @param callback the callback for {!listen} 110 | @param f the function to call after connection *) 111 | end 112 | 113 | module Make : functor (Io: Irc_transport.IO) -> 114 | CLIENT with type 'a Io.t = 'a Io.t 115 | and type Io.inet_addr = Io.inet_addr 116 | and type Io.config = Io.config 117 | -------------------------------------------------------------------------------- /src/core/irc_helpers.ml: -------------------------------------------------------------------------------- 1 | let split ~str ~c = 2 | (* [i]: current index in [str] 3 | [acc]: list of strings split so far *) 4 | let rec rev_split' ~str ~i ~c ~acc = 5 | try 6 | let index = String.index_from str i c in 7 | let before = String.sub str i (index-i) in 8 | rev_split' ~str ~c ~i:(index+1) ~acc:(before :: acc) 9 | with Not_found -> 10 | String.sub str i (String.length str - i) :: acc 11 | in 12 | List.rev (rev_split' ~str ~i:0 ~c ~acc:[]) 13 | 14 | let split1_exn ~str ~c = 15 | let index = String.index str c in 16 | let before = String.sub str 0 index in 17 | let after = String.sub str (index + 1) (String.length str - index - 1) in 18 | before, after 19 | 20 | let get_whole_lines ~str = 21 | let rec find i acc = 22 | try 23 | let j = String.index_from str i '\n' in 24 | if i=j then find (j+1) acc 25 | else 26 | let line = String.sub str i (j-i-1) in 27 | find (j+1) (line :: acc) 28 | with Not_found -> 29 | if i=String.length str 30 | then List.rev acc, `NoRest 31 | else List.rev acc, `Rest (String.sub str i (String.length str - i)) 32 | in 33 | find 0 [] 34 | 35 | let handle_input ~buffer ~input = 36 | (* Append the new input to the buffer. *) 37 | Buffer.add_string buffer input; 38 | let whole_lines, rest = get_whole_lines ~str:(Buffer.contents buffer) in 39 | (* Replace the buffer contents with the last, partial, line. *) 40 | Buffer.clear buffer; 41 | begin match rest with 42 | | `NoRest -> () 43 | | `Rest s -> Buffer.add_string buffer s; 44 | end; 45 | (* Return the whole lines extracted from the buffer. *) 46 | whole_lines 47 | 48 | module Log = (val Logs.src_log (Logs.Src.create ~doc:"irc-client low level logging" "irc-client")) 49 | -------------------------------------------------------------------------------- /src/core/irc_helpers.mli: -------------------------------------------------------------------------------- 1 | (** Helper functions for buffering data as it is read from a socket. *) 2 | 3 | val split : str:string -> c:char -> string list 4 | (** Split a string [str] at each occurrence of the character [c]. *) 5 | 6 | val split1_exn : str:string -> c:char -> string * string 7 | (** Split a string [str] at the first occurrence of the character [c]. 8 | @raise Not_found if the separator isn't found. *) 9 | 10 | val handle_input : buffer:Buffer.t -> input:string -> string list 11 | (** Given a [buffer] and a string [input], append the input to the buffer, 12 | return all whole lines present in the buffer, and reinitialise the buffer to 13 | contain only the substring which follows all the whole lines. *) 14 | 15 | module Log : Logs.LOG 16 | -------------------------------------------------------------------------------- /src/core/irc_message.ml: -------------------------------------------------------------------------------- 1 | (** A type representing an IRC command, 2 | following {{: https://tools.ietf.org/html/rfc2812#section-3} RFC 2812} *) 3 | type command = 4 | | PASS of string 5 | | NICK of string 6 | | USER of string list (** see rfc *) 7 | | OPER of string * string (** name * password *) 8 | | MODE of string * string (** nick * mode string *) 9 | | QUIT of string (** quit message *) 10 | | SQUIT of string * string (** server * comment *) 11 | | JOIN of string list * string list (** channels * key list *) 12 | | JOIN0 (** join 0 (parts all channels) *) 13 | | PART of string list * string (** channels * comment *) 14 | | TOPIC of string * string (** chan * topic *) 15 | | NAMES of string list (** channels *) 16 | | LIST of string list (** channels *) 17 | | INVITE of string * string (** nick * chan *) 18 | | KICK of string list * string * string (** channels * nick * comment *) 19 | | PRIVMSG of string * string (** target * message *) 20 | | NOTICE of string * string (** target * message *) 21 | | PING of string * string 22 | | PONG of string * string 23 | | Other of string * (string list) (** command name * parameters *) 24 | 25 | type t = { 26 | prefix: string option; 27 | command : command; 28 | } 29 | 30 | let make_ cmd = {prefix=None; command=cmd} 31 | let make_other_ cmd params = {prefix=None; command=Other (cmd, params)} 32 | let unwrap_ or_ = function None -> or_ | Some s -> s 33 | 34 | let pass s = make_ (PASS s) 35 | let nick s = make_ (NICK s) 36 | let user ~username ~mode ~realname = 37 | make_ (USER [username; string_of_int mode; "*"; realname]) 38 | let oper ~name ~pass = make_ (OPER (name, pass)) 39 | let mode ~nick ~mode = make_ (MODE (nick, mode)) 40 | let quit ~msg = make_ (QUIT msg) 41 | let join ~chans ~keys = make_ (JOIN (chans, unwrap_ [] keys)) 42 | let join0 = make_ JOIN0 43 | let part ~chans ~comment = make_ (PART (chans, unwrap_ "" comment)) 44 | let topic ~chan ~topic = make_ (TOPIC (chan, unwrap_ "" topic)) 45 | let names ~chans = make_ (NAMES chans) 46 | let list ~chans = make_ (LIST chans) 47 | let invite ~nick ~chan = make_ (INVITE (nick, chan)) 48 | let kick ~chans ~nick ~comment = make_ (KICK (chans, nick, unwrap_ "" comment)) 49 | let privmsg ~target msg = make_ (PRIVMSG (target, msg)) 50 | let notice ~target msg = make_ (NOTICE (target, msg)) 51 | let ping ~message1 ~message2 = make_ (PING (message1, message2)) 52 | let pong ~message1 ~message2 = make_ (PONG (message1, message2)) 53 | 54 | let other ~cmd ~params = make_other_ cmd params 55 | 56 | type 'a or_error = ('a, string) Result.result 57 | type parse_result = t or_error 58 | 59 | let extract_prefix str = 60 | if str <> "" && str.[0] = ':' 61 | then begin 62 | let prefix_length = (String.index str ' ') - 1 in 63 | assert (prefix_length >= 0); 64 | Some (String.sub str 1 prefix_length), 65 | (String.sub str 66 | (prefix_length + 2) 67 | (String.length str - (prefix_length + 2))) 68 | end else 69 | None, str 70 | 71 | let extract_trail str = 72 | try 73 | let trail_start = String.index str ':' + 1 in 74 | let trail_length = String.length str - trail_start in 75 | let rest = 76 | if trail_start > 2 then String.sub str 0 (trail_start - 2) else "" in 77 | rest, Some (String.sub str trail_start trail_length) 78 | with Not_found -> 79 | str, None 80 | 81 | exception ParseError of string * string 82 | 83 | let split_spaces str = Irc_helpers.split ~str ~c:' ' 84 | let split_comma str = Irc_helpers.split ~str ~c:',' 85 | let split_space1 str = Irc_helpers.split1_exn ~str ~c:' ' 86 | 87 | let (|>) x f = f x 88 | 89 | (* split parameters into tokens separated by spaces. If a trail, prefixed 90 | by ':', exists, it is the last token *) 91 | let split_params params = 92 | let s, trail = extract_trail params in 93 | let tokens = 94 | split_spaces s 95 | |> List.map String.trim 96 | |> List.filter (fun s -> s <> "") 97 | in 98 | match trail with 99 | | None -> tokens 100 | | Some trail -> tokens @ [trail] 101 | 102 | let fail_ msg err = raise (ParseError (msg, err)) 103 | 104 | (* expect exactly one word *) 105 | let expect1 msg = function 106 | | [x] -> x 107 | | _ -> fail_ msg "expected one parameter" 108 | and expect2 msg = function 109 | | [x;y] -> x, y 110 | | _ -> fail_ msg "expected two parameters" 111 | and expect1or2 msg = function 112 | | [x] -> x, "" 113 | | [x;y] -> x, y 114 | | _ -> fail_ msg "expected one or two parameters" 115 | and expect2or3 msg = function 116 | | [x;y] -> x, y, "" 117 | | [x;y;z] -> x, y, z 118 | | _ -> fail_ msg "expected one or two parameters" 119 | 120 | let parse_exn msg = 121 | if String.length msg = 0 then 122 | fail_ msg "Zero-length message" 123 | else 124 | let prefix, rest = extract_prefix msg in 125 | let command_name, params = split_space1 rest in 126 | let params = split_params params in 127 | let command = match command_name with 128 | | "PASS" -> PASS (expect1 msg params) 129 | | "NICK" -> NICK (expect1 msg params) 130 | | "USER" -> USER (split_spaces (expect1 msg params)) 131 | | "OPER" -> 132 | let name, pass = expect2 msg params in 133 | OPER (name, pass) 134 | | "MODE" -> 135 | let nick, mode = expect2 msg params in 136 | MODE (nick, mode) 137 | | "QUIT" -> QUIT (expect1 msg params) 138 | | "JOIN" -> 139 | begin match params with 140 | | ["0"] -> JOIN0 141 | | [chans] -> JOIN (split_comma chans, []) 142 | | [chans; keys] -> JOIN (split_comma chans, split_comma keys) 143 | | _ -> fail_ msg "expected one or two parameters to JOIN" 144 | end 145 | | "PART" -> 146 | let chans, msg = expect1or2 msg params in 147 | PART (split_comma chans, msg) 148 | | "TOPIC" -> 149 | let chan, topic = expect1or2 msg params in 150 | TOPIC (chan, topic) 151 | | "NAMES" -> NAMES (split_comma (expect1 msg params)) 152 | | "LIST" -> LIST (split_params (expect1 msg params)) 153 | | "INVITE" -> 154 | let nick, chan = expect2 msg params in 155 | INVITE (nick, chan) 156 | | "KICK" -> 157 | let chans, nick, c = expect2or3 msg params in 158 | KICK (split_comma chans, nick, c) 159 | | "PRIVMSG" -> 160 | let target, msg = expect2 msg params in 161 | PRIVMSG (target, msg) 162 | | "NOTICE" -> 163 | let target, msg = expect2 msg params in 164 | NOTICE (target, msg) 165 | | "PING" -> 166 | let middle, trailer = expect1or2 msg params in 167 | PING (middle, trailer) 168 | | "PONG" -> 169 | let middle, trailer = expect1or2 msg params in 170 | PONG (middle, trailer) 171 | | other -> Other (other, params) 172 | in 173 | { prefix; command } 174 | 175 | let parse s = 176 | try Result.Ok (parse_exn s) 177 | with 178 | | ParseError (m, e) -> 179 | Result.Error (Printf.sprintf "failed to parse \"%s\" because: %s" m e) 180 | | e -> 181 | Result.Error (Printf.sprintf "unexpected error trying to parse \"%s\": %s" 182 | s (Printexc.to_string e)) 183 | 184 | (* write [s] into [buf], possibly as a ':'-prefixed trail *) 185 | let write_trail buf s = 186 | if String.contains s ' ' || String.length s > 0 && s.[0] = ':' 187 | then Buffer.add_char buf ':'; 188 | Buffer.add_string buf s 189 | 190 | (* output list to buffer *) 191 | let write_list ?(trail=false) sep buf l = 192 | let rec iter = function 193 | | [] -> () 194 | | [s] when trail -> write_trail buf s 195 | | [s] -> Buffer.add_string buf s 196 | | s :: ((_ :: _) as tail) -> 197 | Buffer.add_string buf s; 198 | Buffer.add_char buf sep; 199 | iter tail 200 | in 201 | iter l 202 | 203 | let write_cmd_buf buf t = 204 | let pp fmt = Printf.bprintf buf fmt in 205 | match t.command with 206 | | PASS s -> pp "PASS %s" s 207 | | NICK s -> pp "NICK %s" s 208 | | USER s -> pp "USER %a" (write_list ~trail:true ' ') s 209 | | OPER (a,b) -> pp "OPER %s %s" a b 210 | | MODE (a,b) -> pp "MODE %s %s" a b 211 | | QUIT s -> pp "QUIT %a" write_trail s 212 | | SQUIT (a,b) -> pp "SQUIT %s %a" a write_trail b 213 | | JOIN (a,b) -> pp "JOIN %a %a" (write_list ',') a (write_list ',') b 214 | | JOIN0 -> pp "JOIN 0" 215 | | PART (a,b) -> pp "PART %a :%s" (write_list ',') a b 216 | | TOPIC (a,b) -> pp "TOPIC %s %a" a write_trail b 217 | | NAMES l -> pp "NAMES %a" (write_list ',') l 218 | | LIST l -> pp "LIST %a" (write_list ',') l 219 | | INVITE (a,b) -> pp "INVITE %s %s" a b 220 | | KICK (l,nick,c) -> pp "KICK %a %s %a" (write_list ',') l nick write_trail c 221 | | PRIVMSG (a,b) -> pp "PRIVMSG %s %a" a write_trail b 222 | | NOTICE (a,b) -> pp "NOTICE %s %a" a write_trail b 223 | | PING (a,b) -> pp "PING %s %a" a write_trail b 224 | | PONG (a,b) -> pp "PONG %s %a" a write_trail b 225 | | Other (command_name, params) -> 226 | Printf.bprintf buf "%s %a" command_name (write_list ~trail:true ' ') params 227 | 228 | let write_buf buf t = 229 | begin match t.prefix with 230 | | None -> () 231 | | Some s -> Printf.bprintf buf ":%s " s 232 | end; 233 | write_cmd_buf buf t; 234 | () 235 | 236 | let output oc t = 237 | let buf = Buffer.create 64 in 238 | write_buf buf t; 239 | Buffer.output_buffer oc buf 240 | 241 | let to_string t = 242 | let buf = Buffer.create 64 in 243 | write_buf buf t; 244 | Buffer.contents buf 245 | -------------------------------------------------------------------------------- /src/core/irc_message.mli: -------------------------------------------------------------------------------- 1 | (** IRC message parsing. *) 2 | 3 | (** A type representing an IRC command, 4 | following {{: https://tools.ietf.org/html/rfc2812#section-3} RFC 2812} *) 5 | type command = 6 | | PASS of string 7 | | NICK of string 8 | | USER of string list (** see rfc *) 9 | | OPER of string * string (** name * password *) 10 | | MODE of string * string (** nick * mode string *) 11 | | QUIT of string (** quit message *) 12 | | SQUIT of string * string (** server * comment *) 13 | | JOIN of string list * string list (** channels * key list *) 14 | | JOIN0 (** join 0 (parts all channels) *) 15 | | PART of string list * string (** channels * comment *) 16 | | TOPIC of string * string (** chan * topic *) 17 | | NAMES of string list (** channels *) 18 | | LIST of string list (** channels *) 19 | | INVITE of string * string (** nick * chan *) 20 | | KICK of string list * string * string (** channels * nick * comment *) 21 | | PRIVMSG of string * string (** target * message *) 22 | | NOTICE of string * string (** target * message *) 23 | | PING of string * string 24 | | PONG of string * string 25 | | Other of string * string list (** other cases *) 26 | 27 | type t = { 28 | prefix: string option; 29 | command : command; 30 | } 31 | 32 | (** {2 Constructors} *) 33 | 34 | val pass : string -> t 35 | val nick : string -> t 36 | val user : username:string -> mode:int -> realname:string -> t 37 | val oper : name:string -> pass:string -> t 38 | val mode : nick:string -> mode:string -> t 39 | val quit : msg:string -> t 40 | val join : chans:string list -> keys:string list option -> t 41 | val join0 : t 42 | val part : chans:string list -> comment:string option -> t 43 | val topic : chan:string -> topic:string option -> t 44 | val names : chans:string list -> t 45 | val list : chans:string list -> t 46 | val invite : nick:string -> chan:string -> t 47 | val kick : chans:string list -> nick:string -> comment:string option -> t 48 | val privmsg : target:string -> string -> t 49 | val notice : target:string -> string -> t 50 | val ping : message1:string -> message2:string -> t 51 | val pong : message1:string -> message2:string -> t 52 | 53 | val other : cmd:string -> params:string list -> t 54 | 55 | (** {2 Printing} *) 56 | 57 | val to_string : t -> string 58 | (** Format the message into a string that can be sent on IRC *) 59 | 60 | val output : out_channel -> t -> unit 61 | 62 | val write_buf : Buffer.t -> t -> unit 63 | 64 | (** {2 Parsing} *) 65 | 66 | type 'a or_error = ('a, string) Result.result 67 | 68 | type parse_result = t or_error 69 | 70 | exception ParseError of string * string 71 | 72 | val parse : string -> t or_error 73 | (** Attempt to parse an IRC message. *) 74 | 75 | val parse_exn : string -> t 76 | (** [parse_exn s] returns the parsed message 77 | @raise ParseError if the string is not a proper message *) 78 | 79 | (** {2 Low level Functions -- testing} *) 80 | 81 | val extract_prefix : string -> string option * string 82 | (** Exposed for testing - not intended for use. *) 83 | 84 | val extract_trail : string -> string * string option 85 | (** Exposed for testing - not intended for use. *) 86 | -------------------------------------------------------------------------------- /src/core/irc_transport.ml: -------------------------------------------------------------------------------- 1 | module type IO = sig 2 | type 'a t 3 | val (>>=) : 'a t -> ('a -> 'b t) -> 'b t 4 | val (>|=) : 'a t -> ('a -> 'b) -> 'b t 5 | val return : 'a -> 'a t 6 | 7 | type file_descr 8 | 9 | type inet_addr 10 | 11 | type config 12 | 13 | val open_socket : ?config:config -> inet_addr -> int -> file_descr t 14 | val close_socket : file_descr -> unit t 15 | 16 | val read : file_descr -> Bytes.t -> int -> int -> int t 17 | val write : file_descr -> Bytes.t -> int -> int -> int t 18 | 19 | val read_with_timeout : timeout:int -> file_descr -> Bytes.t -> int -> int -> int option t 20 | 21 | val gethostbyname : string -> inet_addr list t 22 | 23 | val iter : ('a -> unit t) -> 'a list -> unit t 24 | val catch : (unit -> 'a t) -> (exn -> 'a t) -> 'a t 25 | 26 | val sleep : int -> unit t 27 | val time : unit -> float 28 | val pick : ('a t list -> 'a t) option 29 | end 30 | -------------------------------------------------------------------------------- /src/core/irc_transport.mli: -------------------------------------------------------------------------------- 1 | (** Type of IO modules which can be used to create an IRC client library, via 2 | the {{:Irc_client.Make.html}Irc_client.Make} functor. *) 3 | 4 | module type IO = sig 5 | type 'a t 6 | val (>>=) : 'a t -> ('a -> 'b t) -> 'b t 7 | val (>|=) : 'a t -> ('a -> 'b) -> 'b t 8 | val return : 'a -> 'a t 9 | 10 | type file_descr 11 | (** A connection to the remote IRC server *) 12 | 13 | type inet_addr 14 | (** Remote addresses *) 15 | 16 | type config 17 | (** Additional configuration, on a per-connection basis. *) 18 | 19 | val open_socket : ?config:config -> inet_addr -> int -> file_descr t 20 | val close_socket : file_descr -> unit t 21 | 22 | val read : file_descr -> Bytes.t -> int -> int -> int t 23 | val write : file_descr -> Bytes.t -> int -> int -> int t 24 | 25 | val read_with_timeout : timeout:int -> file_descr -> Bytes.t -> int -> int -> int option t 26 | (** [read_with_timeout ~timeout fd buf off len] returns [Some n] if it 27 | could read [n] bytes into [buf] (slice [off,...,off+len-1]), 28 | or [None] if nothing was read before [timeout] seconds. *) 29 | 30 | val gethostbyname : string -> inet_addr list t 31 | (** List of IPs that correspond to the given hostname (or an empty 32 | list if none is found) *) 33 | 34 | val iter : ('a -> unit t) -> 'a list -> unit t 35 | 36 | val catch : (unit -> 'a t) -> (exn -> 'a t) -> 'a t 37 | (** Catch asynchronous exception 38 | @since NEXT_RELEASE *) 39 | 40 | val sleep : int -> unit t 41 | (* [sleep t] sleeps for [t] seconds, then returns. *) 42 | 43 | val time : unit -> float 44 | (** Current wall time (used for timeouts). Typically, {!Unix.time}. 45 | @since NEXT_RELEASE *) 46 | 47 | val pick : ('a t list -> 'a t) option 48 | (** OPTIONAL 49 | [pick l] returns the first thread of [l] that terminates (and might 50 | cancel the others) *) 51 | end 52 | -------------------------------------------------------------------------------- /src/lwt/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name irc_client_lwt) 3 | (public_name irc-client-lwt) 4 | (wrapped false) 5 | (libraries result bytes irc-client lwt lwt.unix)) 6 | -------------------------------------------------------------------------------- /src/lwt/irc_client_lwt.ml: -------------------------------------------------------------------------------- 1 | module Io_lwt = struct 2 | type 'a t = 'a Lwt.t 3 | let (>>=) = Lwt.bind 4 | let (>|=) = Lwt.(>|=) 5 | let return = Lwt.return 6 | 7 | type file_descr = Lwt_unix.file_descr 8 | type inet_addr = Lwt_unix.inet_addr 9 | type config = unit 10 | 11 | let open_socket ?config:(_=()) addr port = 12 | let sock = Lwt_unix.socket Lwt_unix.PF_INET Lwt_unix.SOCK_STREAM 0 in 13 | let sockaddr = Lwt_unix.ADDR_INET (addr, port) in 14 | Lwt_unix.connect sock sockaddr >>= fun () -> 15 | return sock 16 | 17 | let close_socket = Lwt_unix.close 18 | 19 | let read = Lwt_unix.read 20 | let write = Lwt_unix.write 21 | 22 | let read_with_timeout ~timeout fd buf off len = 23 | let open Lwt.Infix in 24 | Lwt.pick 25 | [ (read fd buf off len >|= fun i -> Some i); 26 | (Lwt_unix.sleep (float timeout) >|= fun () -> None); 27 | ] 28 | 29 | let gethostbyname name = 30 | Lwt.catch 31 | (fun () -> 32 | Lwt_unix.gethostbyname name >>= fun entry -> 33 | let addrs = Array.to_list entry.Unix.h_addr_list in 34 | Lwt.return addrs 35 | ) (function 36 | | Not_found -> Lwt.return_nil 37 | | e -> Lwt.fail e 38 | ) 39 | 40 | let iter = Lwt_list.iter_s 41 | let sleep d = Lwt_unix.sleep (float d) 42 | let catch = Lwt.catch 43 | let time = Unix.time 44 | 45 | let pick = Some Lwt.pick 46 | end 47 | 48 | include Irc_client.Make(Io_lwt) 49 | -------------------------------------------------------------------------------- /src/lwt/irc_client_lwt.mli: -------------------------------------------------------------------------------- 1 | include Irc_client.CLIENT 2 | with type 'a Io.t = 'a Lwt.t 3 | and type Io.inet_addr = Lwt_unix.inet_addr 4 | and type Io.config = unit 5 | -------------------------------------------------------------------------------- /src/lwt_ssl/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name irc_client_lwt_ssl) 3 | (public_name irc-client-lwt-ssl) 4 | (wrapped false) 5 | (libraries result bytes irc-client lwt ssl lwt_ssl)) 6 | -------------------------------------------------------------------------------- /src/lwt_ssl/irc_client_lwt_ssl.ml: -------------------------------------------------------------------------------- 1 | 2 | module Config = struct 3 | type t = { 4 | check_certificate: bool; 5 | proto: Ssl.protocol; 6 | } 7 | 8 | let default = { check_certificate=false; proto=Ssl.TLSv1_3; } 9 | end 10 | 11 | module Io_lwt_ssl = struct 12 | type 'a t = 'a Lwt.t 13 | let (>>=) = Lwt.bind 14 | let (>|=) = Lwt.(>|=) 15 | let return = Lwt.return 16 | 17 | type file_descr = { 18 | ssl: Ssl.context; 19 | fd: Lwt_ssl.socket; 20 | } 21 | 22 | type config = Config.t 23 | type inet_addr = Lwt_unix.inet_addr 24 | 25 | let open_socket ?(config=Config.default) addr port : file_descr t = 26 | let ssl = Ssl.create_context config.Config.proto Ssl.Client_context in 27 | if config.Config.check_certificate then begin 28 | (* from https://github.com/johnelse/ocaml-irc-client/pull/21 *) 29 | Ssl.set_verify_depth ssl 3; 30 | Ssl.set_verify ssl [Ssl.Verify_peer] (Some Ssl.client_verify_callback); 31 | Ssl.set_client_verify_callback_verbose true; 32 | end; 33 | let sock = Lwt_unix.socket Lwt_unix.PF_INET Lwt_unix.SOCK_STREAM 0 in 34 | let sockaddr = Lwt_unix.ADDR_INET (addr, port) in 35 | (* Printf.printf "connect socket…\n%!"; *) 36 | Lwt_unix.connect sock sockaddr >>= fun () -> 37 | (* Printf.printf "Ssl.connect socket…\n%!"; *) 38 | Lwt_ssl.ssl_connect sock ssl >>= fun sock -> 39 | Lwt.return {fd=sock; ssl} 40 | 41 | let close_socket {fd;ssl=_} = 42 | Lwt_ssl.close fd 43 | 44 | let read {fd;_} i len = Lwt_ssl.read fd i len 45 | let write {fd;_} s i len = Lwt_ssl.write fd s i len 46 | 47 | let read_with_timeout ~timeout fd buf off len = 48 | let open Lwt.Infix in 49 | Lwt.pick 50 | [ (read fd buf off len >|= fun i -> Some i); 51 | (Lwt_unix.sleep (float timeout) >|= fun () -> None); 52 | ] 53 | 54 | let gethostbyname name = 55 | Lwt.catch 56 | (fun () -> 57 | Lwt_unix.gethostbyname name >>= fun entry -> 58 | let addrs = Array.to_list entry.Unix.h_addr_list in 59 | Lwt.return addrs 60 | ) (function 61 | | Not_found -> Lwt.return_nil 62 | | e -> Lwt.fail e 63 | ) 64 | 65 | let iter = Lwt_list.iter_s 66 | let sleep d = Lwt_unix.sleep (float d) 67 | let catch = Lwt.catch 68 | let time = Unix.time 69 | 70 | let pick = Some Lwt.pick 71 | end 72 | 73 | include Irc_client.Make(Io_lwt_ssl) 74 | -------------------------------------------------------------------------------- /src/lwt_ssl/irc_client_lwt_ssl.mli: -------------------------------------------------------------------------------- 1 | module Config : sig 2 | type t = { 3 | check_certificate: bool; 4 | proto: Ssl.protocol; 5 | } 6 | 7 | val default : t 8 | end 9 | 10 | include Irc_client.CLIENT 11 | with type 'a Io.t = 'a Lwt.t 12 | and type Io.inet_addr = Lwt_unix.inet_addr 13 | and type Io.config = Config.t 14 | -------------------------------------------------------------------------------- /src/tls/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name irc_client_tls) 3 | (public_name irc-client-tls) 4 | (wrapped false) 5 | (libraries result bytes irc-client lwt lwt.unix tls tls-lwt)) 6 | -------------------------------------------------------------------------------- /src/tls/irc_client_tls.ml: -------------------------------------------------------------------------------- 1 | module Io_tls = struct 2 | type 'a t = 'a Lwt.t 3 | let (>>=) = Lwt.bind 4 | let (>|=) = Lwt.(>|=) 5 | let return = Lwt.return 6 | 7 | type file_descr = { 8 | ic: Tls_lwt.ic; 9 | oc: Tls_lwt.oc; 10 | } 11 | 12 | type inet_addr = string 13 | 14 | type config = Tls.Config.client 15 | 16 | let default_config : Tls.Config.client = 17 | Tls.Config.client ~authenticator:(fun ?ip:_ ~host:_ _ -> Ok None) () 18 | 19 | let open_socket ?(config=default_config) addr port : file_descr t = 20 | Tls_lwt.connect_ext config (addr,port) >|= fun (ic,oc) -> 21 | {ic; oc} 22 | 23 | let close_socket {ic;oc} = 24 | Lwt.join 25 | [ Lwt_io.close ic; 26 | Lwt_io.close oc; 27 | ] 28 | 29 | let read {ic;_} = Lwt_io.read_into ic 30 | let write {oc;_} = Lwt_io.write_from oc 31 | 32 | let read_with_timeout ~timeout (fd:file_descr) buf off len = 33 | let open Lwt.Infix in 34 | Lwt.pick 35 | [ (Lwt_io.read_into fd.ic buf off len >|= fun i -> Some i); 36 | (Lwt_unix.sleep (float timeout) >|= fun () -> None); 37 | ] 38 | 39 | let gethostbyname name = Lwt.return [name] 40 | 41 | let iter = Lwt_list.iter_s 42 | let sleep d = Lwt_unix.sleep (float d) 43 | let catch = Lwt.catch 44 | let time = Unix.time 45 | 46 | let pick = Some Lwt.pick 47 | end 48 | 49 | include Irc_client.Make(Io_tls) 50 | -------------------------------------------------------------------------------- /src/tls/irc_client_tls.mli: -------------------------------------------------------------------------------- 1 | include Irc_client.CLIENT 2 | with type 'a Io.t = 'a Lwt.t 3 | and type Io.inet_addr = string 4 | and type Io.config = Tls.Config.client 5 | -------------------------------------------------------------------------------- /src/unix/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name irc_client_unix) 3 | (public_name irc-client-unix) 4 | (wrapped false) 5 | (libraries result bytes irc-client unix)) 6 | -------------------------------------------------------------------------------- /src/unix/irc_client_unix.ml: -------------------------------------------------------------------------------- 1 | module Io_unix = struct 2 | type 'a t = 'a 3 | let (>>=) x f = f x 4 | let (>|=) x f = f x 5 | let return x = x 6 | 7 | type file_descr = Unix.file_descr 8 | type inet_addr = Unix.inet_addr 9 | type config = unit 10 | 11 | let open_socket ?config:(_=()) addr port = 12 | let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in 13 | let sockaddr = Unix.ADDR_INET (addr, port) in 14 | Unix.connect sock sockaddr; 15 | Unix.set_nonblock sock; 16 | sock 17 | 18 | let close_socket = Unix.close 19 | 20 | let read = Unix.read 21 | let write = Unix.write 22 | 23 | let read_with_timeout ~timeout fd buf off len = 24 | match Unix.select [fd] [] [] (float timeout) with 25 | | [fd], _, _ -> Some (Unix.read fd buf off len) 26 | | [], _, _ -> None 27 | | _ -> assert false 28 | 29 | let gethostbyname name = 30 | try 31 | let entry = Unix.gethostbyname name in 32 | Array.to_list entry.Unix.h_addr_list 33 | with Not_found -> 34 | [] 35 | 36 | let iter = List.iter 37 | let sleep = Unix.sleep 38 | let catch f g = try f () with e -> g e 39 | let time = Unix.time 40 | 41 | let pick = None 42 | end 43 | 44 | include Irc_client.Make(Io_unix) 45 | 46 | (* unix only allows passive mode *) 47 | let default_keepalive = {mode=`Passive; timeout=300} 48 | 49 | let listen ?(keepalive=default_keepalive) ~connection ~callback () = 50 | listen ~keepalive ~connection ~callback () 51 | 52 | let reconnect_loop ?(keepalive=default_keepalive) ?(reconnect=true) ~after ~connect ~f ~callback () = 53 | reconnect_loop ~keepalive ~reconnect ~after ~connect ~f ~callback () 54 | -------------------------------------------------------------------------------- /src/unix/irc_client_unix.mli: -------------------------------------------------------------------------------- 1 | include Irc_client.CLIENT 2 | with type 'a Io.t = 'a 3 | and type Io.inet_addr = Unix.inet_addr 4 | and type Io.config = unit 5 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name test_unit_main) 3 | (libraries oUnit irc-client)) 4 | 5 | (alias 6 | (name runtest) 7 | (package irc-client) 8 | (action (run ./test_unit_main.exe))) 9 | -------------------------------------------------------------------------------- /test/test_helpers.ml: -------------------------------------------------------------------------------- 1 | open OUnit2 2 | 3 | module H = Irc_helpers 4 | 5 | let pp_strlist l = "[" ^ String.concat ";" l ^ "]" 6 | 7 | let test_split = 8 | let test1 _ = 9 | assert_equal ~printer:pp_strlist 10 | ["ab"; "c"; "d"; "ef"] 11 | (H.split ~str:"ab c d ef" ~c:' ') 12 | and test2 _ = 13 | assert_equal ~printer:pp_strlist 14 | [""; "a"; ""; "b"; "hello"; "world"; ""] 15 | (H.split ~str:" a b hello world " ~c:' ') 16 | in 17 | "test_split" >::: [ "1" >:: test1; "2" >:: test2 ] 18 | 19 | let test_handle_input = 20 | let test buffer_contents input (expected_lines, expected_buffer) = 21 | let buffer = Buffer.create 0 in 22 | Buffer.add_string buffer buffer_contents; 23 | assert_equal ~printer:pp_strlist 24 | expected_lines 25 | (H.handle_input ~buffer ~input); 26 | assert_equal 27 | expected_buffer 28 | (Buffer.contents buffer) 29 | in 30 | "test_handle_input" >::: 31 | (List.map 32 | (fun (name, buffer_contents, input, expected_output) -> 33 | (name >::(fun _ -> test buffer_contents input expected_output))) 34 | [ 35 | ( 36 | "empty", "", "", 37 | ([], "") 38 | ); 39 | ( 40 | "no newline", "", "foo", 41 | ([], "foo") 42 | ); 43 | ( 44 | "one newline", "", "foo\r\n", 45 | (["foo"], "") 46 | ); 47 | ( 48 | "one newline plus extra", "foo", "bar\r\nbaz", 49 | (["foobar"], "baz") 50 | ); 51 | ( 52 | "two newlines", "", "foo\r\nbaz\r\n", 53 | (["foo"; "baz"], "") 54 | ); 55 | ]) 56 | 57 | let suite = 58 | "test_helpers" >::: 59 | [ 60 | test_split; 61 | test_handle_input; 62 | ] 63 | -------------------------------------------------------------------------------- /test/test_message.ml: -------------------------------------------------------------------------------- 1 | open OUnit2 2 | 3 | module H = Irc_helpers 4 | module M = Irc_message 5 | 6 | let test_extract_prefix = 7 | let test ~msg ~input ~expected_output _ = 8 | let parsed = M.extract_prefix input in 9 | assert_equal ~msg parsed expected_output 10 | in 11 | "test_extract_prefix" >::: 12 | [ 13 | "test_no_prefix" >:: 14 | test ~msg:"Parsing a message with no prefix" 15 | ~input:"PING :server.com" 16 | ~expected_output:(None, "PING :server.com"); 17 | "test_prefix" >:: 18 | test ~msg:"Parsing a message with a prefix" 19 | ~input:":nick!user@host PRIVMSG destnick :abc def" 20 | ~expected_output:(Some "nick!user@host", "PRIVMSG destnick :abc def"); 21 | ] 22 | 23 | let test_extract_trail = 24 | let test ~msg ~input ~expected_output _ = 25 | let parsed = M.extract_trail input in 26 | assert_equal ~msg parsed expected_output 27 | in 28 | "test_extract_trail" >::: 29 | [ 30 | "test_no_trail" >:: 31 | test ~msg:"Parsing a message with no trail" 32 | ~input:"PING" 33 | ~expected_output:("PING", None); 34 | "test_trail1" >:: 35 | test ~msg:"Parsing a message with a trail" 36 | ~input:"PING :irc.domain.com" 37 | ~expected_output:("PING", Some "irc.domain.com"); 38 | "test_trail2" >:: 39 | test ~msg:"Parsing a message with a trail and parameters" 40 | ~input:"PRIVMSG destnick :hi there" 41 | ~expected_output:("PRIVMSG destnick", Some "hi there"); 42 | ] 43 | 44 | let test_full_parser = 45 | let test ~msg ~input ~expected_output _ = 46 | let parsed = M.parse input in 47 | assert_equal ~msg parsed expected_output 48 | in 49 | "test_full_parser" >::: 50 | [ 51 | "test_parse_ping" >:: 52 | test ~msg:"Parsing a PING message" 53 | ~input:"PING :abc.def" 54 | ~expected_output:(Result.Ok { 55 | M.prefix = None; 56 | command = M.PING ("abc.def", ""); 57 | }); 58 | "test_parse_privmsg" >:: 59 | test ~msg:"Parsing a PRIVMSG" 60 | ~input:":nick!user@host.com PRIVMSG #channel :Hello all" 61 | ~expected_output:(Result.Ok { 62 | M.prefix = Some "nick!user@host.com"; 63 | command = M.PRIVMSG ("#channel", "Hello all"); 64 | }); 65 | ] 66 | 67 | let suite = 68 | "test_message" >::: 69 | [ 70 | test_extract_prefix; 71 | test_extract_trail; 72 | test_full_parser; 73 | ] 74 | -------------------------------------------------------------------------------- /test/test_unit_main.ml: -------------------------------------------------------------------------------- 1 | open OUnit2 2 | 3 | let base_suite = 4 | "base_suite" >::: 5 | [ 6 | Test_helpers.suite; 7 | Test_message.suite; 8 | ] 9 | 10 | let () = OUnit2.run_test_tt_main base_suite 11 | --------------------------------------------------------------------------------