├── dune-project ├── .ocamlformat ├── unikernel ├── _tags ├── README.md ├── unikernel.ml └── config.ml ├── lib-lwt ├── dune ├── cri_lwt.mli └── cri_lwt.ml ├── lib-logger ├── dune └── cri_logger.ml ├── test ├── dune └── test.ml ├── bin ├── dune ├── ttls.ml ├── socket.ml └── example.ml ├── .gitignore ├── lib ├── cri.ml ├── dune ├── channel.mli ├── nickname.mli ├── encoder.mli ├── destination.mli ├── decoder.mli ├── nickname.ml ├── channel.ml ├── user_mode.ml ├── channel_mode.ml ├── destination.ml ├── encoder.ml ├── protocol.mli ├── decoder.ml └── protocol.ml ├── lib-mirage ├── dune └── cri_mirage.ml ├── LICENSE.md ├── cri.opam └── README.md /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.8) 2 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | version=0.25.1 2 | disable=true 3 | -------------------------------------------------------------------------------- /unikernel/_tags: -------------------------------------------------------------------------------- 1 | true: package(digestif.c), package(checkseum.c) 2 | -------------------------------------------------------------------------------- /lib-lwt/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name cri_lwt) 3 | (public_name cri.lwt) 4 | (libraries cri ke mimic)) 5 | -------------------------------------------------------------------------------- /lib-logger/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name cri_logger) 3 | (public_name cri.logger) 4 | (libraries cri cri.lwt)) 5 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name test) 3 | (libraries cri alcotest)) 4 | 5 | (rule 6 | (alias runtest) 7 | (action 8 | (run ./test.exe --color=always))) 9 | -------------------------------------------------------------------------------- /bin/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name example) 3 | (libraries 4 | mirage-crypto-rng.unix 5 | logs 6 | logs.fmt 7 | fmt.tty 8 | uri 9 | tls-mirage 10 | lwt.unix 11 | cri.lwt 12 | cri.logger)) 13 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | setup.data 3 | setup.log 4 | doc/*.html 5 | *.native 6 | *.byte 7 | *.so 8 | lib/decompress_conf.ml 9 | *.tar.gz 10 | _tests 11 | lib_test/files 12 | zpipe 13 | c/dpipe 14 | *.merlin 15 | *.install -------------------------------------------------------------------------------- /lib/cri.ml: -------------------------------------------------------------------------------- 1 | module Protocol = Protocol 2 | module Decoder = Decoder 3 | module Encoder = Encoder 4 | module Channel = Channel 5 | module User_mode = User_mode 6 | module Nickname = Nickname 7 | module Destination = Destination 8 | -------------------------------------------------------------------------------- /lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name cri) 3 | (public_name cri) 4 | (libraries 5 | logs 6 | ipaddr 7 | ke 8 | astring 9 | rresult 10 | ptime 11 | hxd.string 12 | hxd.core 13 | domain-name 14 | fmt 15 | angstrom)) 16 | -------------------------------------------------------------------------------- /lib-mirage/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name cri_mirage) 3 | (public_name cri.mirage) 4 | (libraries 5 | logs 6 | rresult 7 | uri 8 | mimic 9 | tls-mirage 10 | mirage-stack 11 | mirage-random 12 | mirage-clock 13 | mirage-time 14 | dns-client-mirage)) 15 | -------------------------------------------------------------------------------- /lib/channel.mli: -------------------------------------------------------------------------------- 1 | type t 2 | 3 | module BNF : sig 4 | val channel : t Angstrom.t 5 | end 6 | 7 | val of_string : string -> (t, [> `Msg of string ]) result 8 | val of_string_exn : string -> t 9 | val to_string : t -> string 10 | val pp : t Fmt.t 11 | val equal : t -> t -> bool 12 | val is : string -> bool 13 | -------------------------------------------------------------------------------- /lib/nickname.mli: -------------------------------------------------------------------------------- 1 | type t 2 | 3 | module BNF : sig 4 | val nickname : t Angstrom.t 5 | end 6 | 7 | val of_string : ?strict:bool -> string -> (t, [> `Msg of string ]) result 8 | val of_string_exn : ?strict:bool -> string -> t 9 | val to_string : t -> string 10 | val pp : t Fmt.t 11 | val is : string -> bool 12 | val equal : t -> t -> bool 13 | 14 | module Set : Set.S with type elt = t 15 | -------------------------------------------------------------------------------- /bin/ttls.ml: -------------------------------------------------------------------------------- 1 | include Tls_mirage.Make (Socket) 2 | 3 | type endpoint = Tls.Config.client * [ `host ] Domain_name.t option * Unix.sockaddr 4 | 5 | let pp_sockaddr ppf = function 6 | | Unix.ADDR_UNIX v -> Fmt.pf ppf "" v 7 | | Unix.ADDR_INET (v, p) -> Fmt.pf ppf "%s:%d" (Unix.string_of_inet_addr v) p 8 | 9 | let connect (tls, host, sockaddr) = 10 | let open Lwt.Infix in 11 | Socket.connect sockaddr >>= function 12 | | Error `Closed -> Lwt.return_error `Closed 13 | | Ok flow -> 14 | client_of_flow tls ?host flow >>= fun flow -> 15 | Lwt.return flow 16 | -------------------------------------------------------------------------------- /lib/encoder.mli: -------------------------------------------------------------------------------- 1 | type error = [ `No_enough_space ] 2 | 3 | val pp_error : error Fmt.t 4 | 5 | type encoder 6 | 7 | type 'err state = 8 | | Write of { buffer : string; off : int; len : int; continue : int -> 'err state; } 9 | | Error of 'err 10 | | Done 11 | 12 | val encoder : unit -> encoder 13 | val flush : (unit -> ([> error ] as 'err) state) -> encoder -> 'err state 14 | val write : string -> encoder -> unit 15 | val blit : buf:string -> off:int -> len:int -> encoder -> unit 16 | 17 | type host = 18 | [ `Host of string 19 | | `Ip6 of Ipaddr.V6.t ] 20 | 21 | type t = 22 | [ `User of (string * string option * host option) | `Server of host ] option 23 | * string * (string list * string option) 24 | 25 | val encode_line : (unit -> ([> error ] as 'err) state) -> encoder -> t -> 'err state 26 | -------------------------------------------------------------------------------- /lib/destination.mli: -------------------------------------------------------------------------------- 1 | type mask = | 2 | 3 | type host = 4 | [ `Host of [ `raw ] Domain_name.t 5 | | `Ip6 of Ipaddr.V6.t ] 6 | 7 | type t = 8 | | Channel of Channel.t 9 | | User_with_servername of { user : string 10 | ; host : host option 11 | ; servername : host } 12 | | User_with_host of { user : string 13 | ; host : host } 14 | | Nickname of Nickname.t 15 | | Full_nickname of { nick : Nickname.t 16 | ; user : string 17 | ; host : host } 18 | | Mask of mask 19 | 20 | val pp : t Fmt.t 21 | 22 | module BNF : sig 23 | val destination : t list Angstrom.t 24 | end 25 | 26 | val to_string : t -> string 27 | val of_string : string -> (t list, [> `Msg of string ]) result 28 | val of_string_exn : string -> t list 29 | val everywhere : t -> bool 30 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2021 Romain Calascibetta 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy of 6 | this software and associated documentation files (the "Software"), to deal in 7 | the Software without restriction, including without limitation the rights to 8 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of 9 | the Software, and to permit persons to whom the Software is furnished to do so, 10 | 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, FITNESS 17 | FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR 18 | COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER 19 | IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 20 | CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /cri.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "cri" 3 | synopsis: "Implementation of IRC in OCaml" 4 | description: "Cri is a simple implementation of IRC in OCaml." 5 | maintainer: "Romain Calascibetta " 6 | authors: "Romain Calascibetta " 7 | license: "MIT" 8 | homepage: "https://github.com/dinosaure/cri" 9 | doc: "https://dinosaure.github.io/cri/" 10 | bug-reports: "https://github.com/dinosaure/cri/issues" 11 | depends: [ 12 | "ocaml" {>= "4.07.0"} 13 | "dune" {>= "2.8.0"} 14 | "angstrom" {>= "0.15.0"} 15 | "dns-client" {>= "5.0.1"} 16 | "dns-client-mirage" 17 | "domain-name" {>= "0.3.0"} 18 | "fmt" {>= "0.8.9"} 19 | "hxd" {>= "0.3.1"} 20 | "ipaddr" {>= "5.0.1"} 21 | "ke" {>= "0.4"} 22 | "logs" {>= "0.7.0"} 23 | "mimic" {>= "0.0.3"} 24 | "mirage-clock" {>= "3.1.0"} 25 | "mirage-random" {>= "2.0.0"} 26 | "mirage-stack" {>= "2.2.0"} 27 | "mirage-time" {>= "2.0.1"} 28 | "ptime" {>= "0.8.5"} 29 | "rresult" {>= "0.6.0"} 30 | "tls-mirage" {>= "0.14.0"} 31 | "uri" {>= "4.2.0"} 32 | "astring" {>= "0.8.5"} 33 | "logs" 34 | "bigstringaf" {>= "0.9.1"} 35 | "alcotest" {>= "1.4.0" & with-test} 36 | ] 37 | build: ["dune" "build" "-p" name "-j" jobs] 38 | run-test: ["dune" "runtest" "-p" name "-j" jobs] 39 | dev-repo: "git+https://github.com/dinosaure/cri.git" 40 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Cri, an implementation of IRC in OCaml for MirageOS 2 | 3 | `cri` is a little library which implements the core of the IRC client 4 | according to [RFC1459][RFC1459] and [RFC2812][RFC2812]. It's a Proof-of-Concept 5 | to show the usual MirageOS development process. Specially the abstraction 6 | required to be compatible with MirageOS. 7 | 8 | However, a simple example exists into the `bin` directory which is a 9 | specialisation of `cri` with `unix`. 10 | 11 | ## A simple bot logger 12 | 13 | To help the development of `cri` and iterate on it, the distribution comes with 14 | a simple logger which call periodically a function with saved messages. The 15 | implementation of it is available into `lib-logger`. 16 | 17 | Then, an unikernel (into `unikernel`) extends it to save these messages into a 18 | Git repository (via [`ocaml-git`][ocaml-git]/[`irmin`][irmin]). It permits to 19 | show a small unikernel as an example of what we can do with MirageOS. 20 | 21 | ## Experimental status 22 | 23 | Many parts of the IRC protocol are not implemented yet and we still continue to 24 | work on them. But the most common commands/responses are implemented. 25 | 26 | [RFC1459]: https://datatracker.ietf.org/doc/html/rfc1459 27 | [RFC2812]: https://datatracker.ietf.org/doc/html/rfc2812 28 | [ocaml-git]: https://github.com/mirage/ocaml-git 29 | [irmin]: https://github.com/mirage/irmin 30 | -------------------------------------------------------------------------------- /lib/decoder.mli: -------------------------------------------------------------------------------- 1 | type error = [ `End_of_input | `Expected_eol | `Expected_line | `Invalid_line of string ] 2 | 3 | val pp_error : error Fmt.t 4 | 5 | type 'err info = { error : 'err; buffer : bytes; committed : int; max : int; } 6 | 7 | val pp_error_with_info : pp:'err Fmt.t -> 'err info Fmt.t 8 | 9 | type ('v, 'err) state = 10 | | Done of int * 'v 11 | | Read of { buffer : Bytes.t 12 | ; off : int; len : int 13 | ; continue : int -> ('v, 'err) state } 14 | | Error of 'err info 15 | 16 | type decoder 17 | 18 | val decoder : unit -> decoder 19 | val decoder_from : string -> decoder 20 | val io_buffer_size : int 21 | 22 | type host = 23 | [ `Host of string 24 | | `Ip6 of Ipaddr.V6.t ] 25 | 26 | type t = 27 | [ `User of (string * string option * host option) | `Server of host ] option 28 | * string * (string list * string option) 29 | 30 | module BNF : sig 31 | val name : string Angstrom.t 32 | val host : [ `Host of string | `Ip6 of Ipaddr.V6.t ] Angstrom.t 33 | val servername : [ `Host of string | `Ip6 of Ipaddr.V6.t ] Angstrom.t 34 | val user : string Angstrom.t 35 | end 36 | 37 | val at_least_one_line : decoder -> bool 38 | 39 | val junk_eol : decoder -> unit 40 | 41 | val peek_line : 42 | k:(t -> decoder -> ('v, [> error ] as 'err) state) 43 | -> decoder -> ('v, 'err) state 44 | 45 | val leave_with : decoder -> 'err -> (_, 'err) state 46 | 47 | val return : decoder -> 'a -> ('a, _) state 48 | val bind : ('a, 'err) state -> ('a -> ('b, 'err) state) -> ('b, 'err) state 49 | val reword_error : ('err0 -> 'err1) -> ('a, 'err0) state -> ('a, 'err1) state 50 | -------------------------------------------------------------------------------- /lib/nickname.ml: -------------------------------------------------------------------------------- 1 | type t = string 2 | 3 | module BNF = struct 4 | open Angstrom 5 | 6 | let nickname = peek_char >>= function 7 | | Some ('a' .. 'z' | 'A' .. 'Z' | '\x5b' .. '\x60' | '\x7b' .. '\x7d') -> 8 | ( take_while1 @@ function 9 | | 'a' .. 'z' 10 | | 'A' .. 'Z' 11 | | '0' .. '9' 12 | | '\x5b' .. '\x60' 13 | | '\x7b' .. '\x7d' 14 | | '-' -> true 15 | | _ -> false ) 16 | | _ -> fail "nickname" 17 | end 18 | 19 | let for_all p str = 20 | let res = ref true in 21 | for i = 0 to String.length str - 1 22 | do res := !res && p str.[i] done ; !res 23 | 24 | let is = function 25 | | 'a' .. 'z' 26 | | 'A' .. 'Z' 27 | | '0' .. '9' 28 | | '-' 29 | | '\x5b' .. '\x60' 30 | | '\x7b' .. '\x7d' -> true 31 | | _ -> false 32 | 33 | let of_string ?(strict= false) str = 34 | if str = "" then Rresult.R.error_msgf "A nickname can not be empty" 35 | else if String.length str > 9 && strict 36 | then Rresult.R.error_msgf "A nickname can not be larger than 9 bytes" 37 | else match str.[0] with 38 | | 'a' .. 'z' 39 | | 'A' .. 'Z' 40 | | '\x5b' .. '\x60' 41 | | '\x7b' .. '\x7d' -> 42 | if for_all is str 43 | then Ok str else Rresult.R.error_msgf "Invalid nickname: %S" str 44 | | _ -> Rresult.R.error_msgf "Invalid nickname: %S" str 45 | (* XXX(dinosaure): according to RFC 2812 but be resilient 46 | * with larger nickname (<3 @kit_ty_kate). *) 47 | 48 | let is str = match of_string str with 49 | | Ok _ -> true | _ -> false 50 | 51 | let to_string x = x 52 | 53 | let of_string_exn ?strict str = match of_string ?strict str with 54 | | Ok v -> v | Error (`Msg err) -> invalid_arg err 55 | 56 | let pp = Fmt.string 57 | let equal = String.equal 58 | 59 | module Set = Set.Make (String) 60 | -------------------------------------------------------------------------------- /lib/channel.ml: -------------------------------------------------------------------------------- 1 | type t = string 2 | 3 | let for_all p str = 4 | let res = ref true in 5 | for i = 0 to String.length str - 1 6 | do res := !res && p str.[i] done ; !res 7 | 8 | module BNF = struct 9 | open Angstrom 10 | 11 | let chanstring = take_while1 @@ function 12 | | '\x01' .. '\x07' 13 | | '\x08' .. '\x09' 14 | | '\x0b' .. '\x0c' 15 | | '\x0e' .. '\x1f' 16 | | '\x21' .. '\x2b' 17 | | '\x2d' .. '\x39' 18 | | '\x3b' .. '\xff' -> true 19 | | _ -> false 20 | (* XXX(dinosaure): according to RFC 2812, [chanstring] is only 21 | * one byte. Here, we use [take_while1] - so one or many bytes. 22 | * I'm not sure that is the right way. *) 23 | 24 | let channelid = take 5 >>= fun str -> 25 | if for_all (function 'A' .. 'Z' | '0' .. '9' -> true | _ -> false) str 26 | then return str else fail "channelid" 27 | 28 | let channel = peek_char >>= function 29 | | Some ('#' | '+' | '&') -> 30 | chanstring >>= fun a -> option "" (char ':' *> chanstring >>| ( ^ ) ":") >>= fun b -> 31 | return (a ^ b) 32 | | Some '!' -> 33 | (advance 1 *> channelid >>| ( ^ ) "!") >>= fun a -> 34 | chanstring >>= fun b -> 35 | option "" (char ':' *> chanstring >>| ( ^ ) ":") >>= fun c -> 36 | return (a ^ b ^ c) 37 | | _ -> 38 | chanstring >>= fun a -> 39 | option "" (char ':' *> chanstring >>| ( ^ ) ":") >>= fun b -> 40 | return (a ^ b) 41 | 42 | let validate str = 43 | match Angstrom.parse_string ~consume:All channel str with 44 | | Ok _ -> true | Error _ -> false 45 | end 46 | 47 | let of_string str = 48 | if BNF.validate str 49 | then Ok str 50 | else Rresult.R.error_msgf "Invalid channel: %S" str 51 | 52 | let of_string_exn str = 53 | match of_string str with 54 | | Ok v -> v 55 | | Error (`Msg err) -> invalid_arg err 56 | 57 | let is str = match of_string str with 58 | | Ok _ -> true | Error _ -> false 59 | 60 | let to_string x = x 61 | 62 | let pp = Fmt.string 63 | let equal = String.equal 64 | -------------------------------------------------------------------------------- /bin/socket.ml: -------------------------------------------------------------------------------- 1 | type endpoint = Unix.sockaddr 2 | 3 | type error = Unix.error * string * string 4 | type write_error = [ `Closed | `Unix of (Unix.error * string * string) ] 5 | 6 | let pp_error : error Fmt.t = fun ppf (err, f, args) -> 7 | Fmt.pf ppf "%s(%s): %s" f args (Unix.error_message err) 8 | 9 | let pp_write_error : write_error Fmt.t = fun ppf -> function 10 | | `Closed -> Fmt.string ppf "Connection closed by peer" 11 | | `Unix (err, f, args) -> Fmt.pf ppf "%s(%s): %s" f args (Unix.error_message err) 12 | 13 | type flow = Lwt_unix.file_descr 14 | 15 | open Lwt.Infix 16 | 17 | let connect sockaddr = 18 | let domain = Unix.domain_of_sockaddr sockaddr in 19 | let socket = Lwt_unix.socket domain Unix.SOCK_STREAM 0 in 20 | Lwt_unix.connect socket sockaddr >>= fun () -> 21 | Lwt_unix.set_blocking socket false ; (* See RFC 1459, 8.11 *) 22 | Lwt.return_ok socket 23 | 24 | let protect f = 25 | Lwt.catch f @@ function 26 | | Unix.Unix_error (err, f, args) -> Lwt.return_error (err, f, args) 27 | | exn -> raise exn 28 | 29 | let read flow = 30 | let tmp = Bytes.create 0x1000 in 31 | let process () = 32 | Lwt_unix.read flow tmp 0 0x1000 >>= function 33 | | 0 -> Lwt.return_ok `Eof 34 | | len -> Lwt.return_ok (`Data (Cstruct.of_bytes ~off:0 ~len tmp)) in 35 | protect process 36 | 37 | let rec write flow cs = 38 | go flow (Cstruct.to_bytes cs) 0 (Cstruct.length cs) 39 | and go flow tmp off len = 40 | Lwt.catch begin fun () -> 41 | Lwt_unix.write flow tmp off len >>= fun len' -> 42 | if len - len' = 0 then Lwt.return_ok () 43 | else go flow tmp (off + len') (len - len') 44 | end @@ function 45 | | Unix.Unix_error (err, f, args) -> Lwt.return_error (`Unix (err, f, args)) 46 | | exn -> raise exn 47 | 48 | let ( >>? ) = Lwt_result.bind 49 | 50 | let rec writev flow css = go flow css 51 | and go flow = function 52 | | [] -> Lwt.return_ok () 53 | | cs :: css -> write flow cs >>? fun () -> go flow css 54 | 55 | let close flow = Lwt.catch (fun () -> Lwt_unix.close flow) (fun _exn -> Lwt.return_unit) 56 | -------------------------------------------------------------------------------- /lib-lwt/cri_lwt.mli: -------------------------------------------------------------------------------- 1 | (* {1 Cri with lwt.} 2 | 3 | An IRC client/server is two concurrent threads: 4 | - one to read 5 | - one to write 6 | 7 | They can be synchronized each others by a shared state. [Cri_lwt] provides 8 | the ground-zero about IRC. It does not describe any high-level logics about 9 | what the bot (if you want to implement a client) or the server must do. 10 | 11 | It gives you only: 12 | - a function to wait the next message 13 | - a function to send the next message 14 | - a thread which fills and consumes the {i reader} 15 | and the {i writer}. 16 | 17 | By this way, the API permits to the user to describe and implement what he 18 | wants without the hard logic about the I/O. Such design is inherent to what 19 | IRC is: the protocol does not describe a synchronization mechanism between 20 | the reader and the writer. In others words, if you send a command, you can 21 | have something else than the expected reply! 22 | 23 | The job to ignore, consume and move forward about a given {i state} (if you 24 | are connected, authentified, etc.) is at the discretion of the user. From 25 | such interface, you can implement a monadic-view of the IRC protocol with 26 | a state containing the {i reader} {b and} the {i writer} - but you will 27 | loose the concurrent capacity between them. Such scenario can help you if 28 | you want to implement a bot. However, it does not fit for a server! *) 29 | 30 | type error = 31 | [ `End_of_input 32 | | `Decoder of Cri.Protocol.error Cri.Decoder.info 33 | | `Write of Mimic.write_error 34 | | `Time_out 35 | | Cri.Encoder.error 36 | | Mimic.error ] 37 | 38 | val pp_error : error Fmt.t 39 | 40 | type recv = unit -> (Cri.Protocol.prefix option * Cri.Protocol.message) option Lwt.t 41 | type send = { send : 'a. ?prefix:Cri.Protocol.prefix -> 'a Cri.Protocol.t -> 'a -> unit } [@@unboxed] 42 | type close = unit -> unit 43 | 44 | val run : 45 | ?connected:(unit -> unit Lwt.t) 46 | -> ?stop:Lwt_switch.t 47 | -> ?timeout:(unit -> unit Lwt.t) 48 | -> Mimic.ctx 49 | -> [ `Fiber of (unit, error) result Lwt.t ] 50 | * recv * send * close 51 | -------------------------------------------------------------------------------- /lib/user_mode.ml: -------------------------------------------------------------------------------- 1 | type t = Away | Invisible | Wallops | Restricted | Operator | Local_operator | Notices 2 | 3 | let of_letter = function 4 | | 'a' -> Ok Away 5 | | 'i' -> Ok Invisible 6 | | 'w' -> Ok Wallops 7 | | 'r' -> Ok Restricted 8 | | 'o' -> Ok Operator 9 | | 'O' -> Ok Local_operator 10 | | 's' -> Ok Notices 11 | | chr -> Rresult.R.error_msgf "Invalid user mode letter: %S" (String.make 1 chr) 12 | 13 | let to_letter = function 14 | | Away -> 'a' 15 | | Invisible -> 'i' 16 | | Wallops -> 'w' 17 | | Restricted -> 'r' 18 | | Operator -> 'o' 19 | | Local_operator -> 'O' 20 | | Notices -> 's' 21 | 22 | type modes = 23 | { add : t list 24 | ; rem : t list } 25 | 26 | let pp ppf { add; rem; } = match add, rem with 27 | | [], [] -> () 28 | | [], _ :: _ -> Fmt.pf ppf "-%a" Fmt.(list ~sep:nop (using to_letter char)) rem 29 | | _ :: _, [] -> Fmt.pf ppf "+%a" Fmt.(list ~sep:nop (using to_letter char)) add 30 | | _ -> Fmt.pf ppf "+%a-%a" 31 | Fmt.(list ~sep:nop (using to_letter char)) add 32 | Fmt.(list ~sep:nop (using to_letter char)) rem 33 | 34 | let of_string ?(ignore= true) str = 35 | let add v lst = if List.exists ((=) v) lst then lst else v :: lst in 36 | let rec go ~neg acc idx = 37 | if idx >= String.length str then Ok acc 38 | else match str.[idx] with 39 | | '+' -> go ~neg:false acc (succ idx) 40 | | '-' -> go ~neg:true acc (succ idx) 41 | | chr -> match of_letter chr with 42 | | Error _ when ignore -> go ~neg acc (succ idx) 43 | | Error _ -> Rresult.R.error_msgf "Bad modes: %S" str 44 | | Ok v -> 45 | let acc = 46 | if neg then { acc with rem= add v acc.rem } 47 | else { acc with add= add v acc.add } in 48 | go ~neg acc (succ idx) in 49 | go ~neg:false { add= []; rem= []; } 0 50 | 51 | let to_string { add; rem; } = 52 | let len = match add, rem with 53 | | [], _ :: _ -> 1 + List.length rem 54 | | _ :: _, [] -> 1 + List.length add 55 | | [], [] -> 0 56 | | _ :: _, _ :: _ -> 2 + List.length add + List.length rem in 57 | let res = Bytes.create len in 58 | let pos = ref 0 in 59 | if add <> [] then ( Bytes.set res !pos '+' ; incr pos 60 | ; List.iter (fun v -> Bytes.set res !pos (to_letter v) ; incr pos) add ) ; 61 | if rem <> [] then ( Bytes.set res !pos '-' ; incr pos 62 | ; List.iter (fun v -> Bytes.set res !pos (to_letter v) ; incr pos) rem ) ; 63 | Bytes.unsafe_to_string res 64 | 65 | let to_int lst = 66 | let res = ref 0 in 67 | List.iter (function 68 | | Away -> res := !res lor 0b10 69 | | Invisible -> res := !res lor 0b100 70 | | _ -> ()) lst; !res 71 | -------------------------------------------------------------------------------- /lib/channel_mode.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | | Channel_creator 3 | | Channel_operator 4 | | Voice_privilege 5 | | Anonymous 6 | | Invite_only 7 | | Moderated 8 | | Ostracize (* n *) 9 | | Quiet 10 | | Private 11 | | Secret 12 | | Server_reop 13 | | Topic 14 | | Key 15 | | User_limit 16 | | Ban_mask 17 | | Exception_mask 18 | | Invitation_mask 19 | 20 | let of_letter = function 21 | | 'O' -> Ok Channel_creator 22 | | 'o' -> Ok Channel_operator 23 | | 'v' -> Ok Voice_privilege 24 | | 'a' -> Ok Anonymous 25 | | 'i' -> Ok Invite_only 26 | | 'm' -> Ok Moderated 27 | | 'n' -> Ok Ostracize 28 | | 'q' -> Ok Quiet 29 | | 'p' -> Ok Private 30 | | 's' -> Ok Secret 31 | | 'r' -> Ok Server_reop 32 | | 't' -> Ok Topic 33 | | 'k' -> Ok Key 34 | | 'l' -> Ok User_limit 35 | | 'b' -> Ok Ban_mask 36 | | 'e' -> Ok Exception_mask 37 | | 'I' -> Ok Invitation_mask 38 | | chr -> Rresult.R.error_msgf "Invalid channel mode letter: %S" 39 | (String.make 1 chr) 40 | 41 | let to_letter = function 42 | | Channel_creator -> 'O' 43 | | Channel_operator -> 'o' 44 | | Voice_privilege -> 'v' 45 | | Anonymous -> 'a' 46 | | Invite_only -> 'i' 47 | | Moderated -> 'm' 48 | | Ostracize -> 'n' 49 | | Quiet -> 'q' 50 | | Private -> 'p' 51 | | Secret -> 's' 52 | | Server_reop -> 'r' 53 | | Topic -> 't' 54 | | Key -> 'k' 55 | | User_limit -> 'l' 56 | | Ban_mask -> 'b' 57 | | Exception_mask -> 'e' 58 | | Invitation_mask -> 'I' 59 | 60 | type modes = 61 | { add : t list 62 | ; rem : t list } 63 | 64 | let of_string ?(ignore= true) str = 65 | let add v lst = 66 | if List.exists ((=) v) lst 67 | then lst else v :: lst in 68 | let rec go ~neg acc idx = 69 | if idx >= String.length str then Ok acc 70 | else match str.[idx] with 71 | | '+' -> go ~neg:false acc (succ idx) 72 | | '-' -> go ~neg:true acc (succ idx) 73 | | chr -> match of_letter chr with 74 | | Error _ when ignore -> go ~neg acc (succ idx) 75 | | Error _ -> Rresult.R.error_msgf "Bad modes: %S" str 76 | | Ok v -> 77 | let acc = 78 | if neg then { acc with rem= add v acc.rem } 79 | else { acc with add= add v acc.add } in 80 | go ~neg acc (succ idx) in 81 | go ~neg:false { add= []; rem= []; } 0 82 | 83 | let to_string { add; rem; } = 84 | let len = match add, rem with 85 | | [], _ :: _ -> 1 + List.length rem 86 | | _ :: _, [] -> 1 + List.length add 87 | | [], [] -> 0 88 | | _ :: _, _ :: _ -> 2 + List.length add + List.length rem in 89 | let res = Bytes.create len in 90 | let pos = ref 0 in 91 | if add <> [] 92 | then ( Bytes.set res !pos '+' ; incr pos 93 | ; List.iter (fun v -> Bytes.set res !pos (to_letter v) ; incr pos) add ) ; 94 | if rem <> [] 95 | then ( Bytes.set res !pos '-' ; incr pos 96 | ; List.iter (fun v -> Bytes.set res !pos (to_letter v) ; incr pos) rem ) ; 97 | Bytes.unsafe_to_string res 98 | 99 | let of_string_exn ?ignore str = match of_string ?ignore str with 100 | | Ok v -> v | Error (`Msg err) -> invalid_arg err 101 | -------------------------------------------------------------------------------- /lib/destination.ml: -------------------------------------------------------------------------------- 1 | type mask = | 2 | 3 | type host = 4 | [ `Host of [ `raw ] Domain_name.t 5 | | `Ip6 of Ipaddr.V6.t ] 6 | 7 | type t = 8 | | Channel of Channel.t 9 | | User_with_servername of { user : string 10 | ; host : host option 11 | ; servername : host } 12 | | User_with_host of { user : string 13 | ; host : host } 14 | | Nickname of Nickname.t 15 | | Full_nickname of { nick : Nickname.t 16 | ; user : string 17 | ; host : host } 18 | | Mask of mask 19 | 20 | let pp_host ppf = function 21 | | `Host v -> Domain_name.pp ppf v 22 | | `Ip6 v -> Ipaddr.V6.pp ppf v 23 | 24 | let pp ppf = function 25 | | Channel v -> Channel.pp ppf v 26 | | User_with_servername { user; host; servername; } -> 27 | Fmt.pf ppf "%s%a@%a" user Fmt.(option ((const string "%") ++ pp_host)) host 28 | pp_host servername 29 | | User_with_host { user; host; } -> 30 | Fmt.pf ppf "%s%%%a" user pp_host host 31 | | Nickname v -> Nickname.pp ppf v 32 | | Full_nickname { nick; user; host; } -> 33 | Fmt.pf ppf "%a!%s@%a" Nickname.pp nick 34 | user pp_host host 35 | | Mask _ -> . 36 | 37 | module BNF = struct 38 | open Angstrom 39 | 40 | let channel = Channel.BNF.channel 41 | let nickname = Nickname.BNF.nickname 42 | let user = Decoder.BNF.user 43 | let host = Decoder.BNF.host >>| function 44 | | `Host v -> `Host (Domain_name.of_string_exn v) 45 | | `Ip6 v -> `Ip6 v 46 | let servername = host 47 | 48 | let msgto = 49 | (channel >>| fun v -> Channel v) 50 | <|> (user >>= fun user -> option None (char '%' *> host >>| Option.some) >>= fun host -> 51 | char '@' *> servername >>= fun servername -> 52 | return (User_with_servername { user; host; servername; })) 53 | <|> (user >>= fun user -> char '%' *> host >>= fun host -> 54 | return (User_with_host { user; host; })) 55 | <|> (nickname >>| fun v -> Nickname v) 56 | <|> (nickname >>= fun nick -> char '!' *> user >>= fun user -> 57 | char '@' *> host >>= fun host -> 58 | return (Full_nickname { nick; user; host; })) 59 | 60 | let destination = msgto >>= fun x -> many (char ',' *> msgto) >>= fun r -> return (x :: r) 61 | let crlf = string "\r\n" 62 | end 63 | 64 | let to_string = function 65 | | Channel v -> Channel.to_string v 66 | | User_with_servername { user; host; servername; } -> 67 | Fmt.str "%s%a@%a" user Fmt.(option ((const string "%") ++ pp_host)) host 68 | pp_host servername 69 | | User_with_host { user; host; } -> 70 | Fmt.str "%s%%%a" user pp_host host 71 | | Nickname v -> Nickname.to_string v 72 | | Full_nickname { nick; user; host; } -> 73 | Fmt.str "%a!%s@%a" Nickname.pp nick user pp_host host 74 | | Mask _ -> . 75 | 76 | let of_string str = 77 | match Angstrom.parse_string ~consume:All 78 | Angstrom.(BNF.destination <* BNF.crlf) (str ^ "\r\n") with 79 | | Ok vs -> Ok vs 80 | | Error _ -> Rresult.R.error_msgf "Invalid target: %S" str 81 | 82 | let of_string_exn str = match of_string str with 83 | | Ok vs -> vs 84 | | Error (`Msg err) -> invalid_arg err 85 | 86 | let everywhere = function 87 | | Channel ch -> Channel.equal (Channel.of_string_exn "*") ch 88 | | _ -> false 89 | -------------------------------------------------------------------------------- /test/test.ml: -------------------------------------------------------------------------------- 1 | let channel = Alcotest.testable Cri.Channel.pp Cri.Channel.equal 2 | let domain_name = Alcotest.testable Domain_name.pp Domain_name.equal 3 | 4 | let test01 = 5 | Alcotest.test_case "destination" `Quick @@ fun () -> 6 | match Cri.Destination.of_string "#mirage" with 7 | | Ok [ Channel ch ] -> 8 | Alcotest.(check channel) "channel" ch (Cri.Channel.of_string_exn "#mirage") 9 | | Ok vs -> Alcotest.failf "Unexpected destination: %a" Fmt.(Dump.list Cri.Destination.pp) vs 10 | | Error _ -> Alcotest.failf "Invalid destination: %S" "#mirage" 11 | 12 | let test02 = 13 | Alcotest.test_case "ping" `Quick @@ fun () -> 14 | let line = "PING :zinc.libera.chat\r\n" in 15 | let dec = Cri.Decoder.decoder_from line in 16 | match Cri.Protocol.decode dec Cri.Protocol.any with 17 | | Cri.Decoder.Done (_, (None, Cri.Protocol.Message (Ping, (None, Some v)))) -> 18 | Alcotest.(check domain_name) "domain-name" v (Domain_name.of_string_exn "zinc.libera.chat") 19 | | Cri.Decoder.Done _ -> Alcotest.failf "Unexpected message" 20 | | _ -> Alcotest.failf "Invalid state of decoding" 21 | 22 | let test03 = 23 | Alcotest.test_case "ipv6" `Quick @@ fun () -> 24 | let line = ":d_bot!~d_bot@2001:4802:7800:1:be76:4eff:fe20:3027 PRIVMSG #ocaml : Hi\r\n" in 25 | let dec = Cri.Decoder.decoder_from line in 26 | match Cri.Protocol.decode dec Cri.Protocol.any with 27 | | Cri.Decoder.Done (_, 28 | (Some _prefix, Cri.Protocol.Message (Privmsg, ([ Cri.Destination.Channel ch ], msg)))) -> 29 | Alcotest.(check channel) "channel" ch (Cri.Channel.of_string_exn "#ocaml") ; 30 | Alcotest.(check string) "message" msg " Hi" 31 | | Cri.Decoder.Done _ -> Alcotest.failf "Unexpected message" 32 | | _ -> Alcotest.failf "Invalid state of decoding" 33 | 34 | let test04 = 35 | Alcotest.test_case "join" `Quick @@ fun () -> 36 | let line = ":habnabit_!~habnabit@python/site-packages/habnabit JOIN #ocaml\r\n" in 37 | let dec = Cri.Decoder.decoder_from line in 38 | match Cri.Protocol.decode dec Cri.Protocol.any with 39 | | Cri.Decoder.Done (_, (Some _prefix, Cri.Protocol.Message (Join, [ ch, _ ]))) -> 40 | Alcotest.(check channel) "channel" ch (Cri.Channel.of_string_exn "#ocaml") 41 | | Cri.Decoder.Done _ -> Alcotest.failf "Unexpected message" 42 | | _ -> Alcotest.failf "Invalid state of decoding" 43 | 44 | let test05 = 45 | Alcotest.test_case "quit" `Quick @@ fun () -> 46 | let line = ":_whitelogger!~whitelogg@uruz.whitequark.org QUIT :Remote host closed the connection\r\n" in 47 | let dec = Cri.Decoder.decoder_from line in 48 | match Cri.Protocol.decode dec Cri.Protocol.Any with 49 | | Cri.Decoder.Done _ -> () 50 | | _ -> Alcotest.failf "Invalid state of decoding" 51 | 52 | let test06 = 53 | Alcotest.test_case "many" `Quick @@ fun () -> 54 | let lines = 55 | "PING :zinc.libera.chat\r\n\ 56 | PONG :zinc.libera.chat\r\n" in 57 | let dec = Cri.Decoder.decoder_from lines in 58 | match Cri.Protocol.decode dec Cri.Protocol.many with 59 | | Cri.Decoder.Done (_, [ (_, Message (Ping, _)); (_, Message (Pong, _)) ]) -> 60 | Alcotest.(check pass) "decoding" () () 61 | | _ -> Alcotest.failf "Invalid state of decoding" 62 | 63 | let test07 = 64 | Alcotest.test_case "mode" `Quick @@ fun () -> 65 | let line = ":hannes!~hannes@193.30.40.133 MODE #mirage -o hannes\r\n" in 66 | let dec = Cri.Decoder.decoder_from line in 67 | match Cri.Protocol.decode dec Cri.Protocol.any with 68 | | Cri.Decoder.Done (_, (_, Cri.Protocol.Message (Channel_mode, { channel= ch; modes= [ _, Some "hannes" ]; }))) -> 69 | Alcotest.(check channel) "channel" ch (Cri.Channel.of_string_exn "#mirage") ; 70 | () 71 | | _ -> Alcotest.failf "Invalid state of decoding" 72 | 73 | let () = 74 | Alcotest.run "cri" [ "BNF", [ test01; test02; test03; test04; test05; test06; test07 ] ] 75 | -------------------------------------------------------------------------------- /lib/encoder.ml: -------------------------------------------------------------------------------- 1 | type encoder = { payload : bytes; mutable pos : int; } 2 | 3 | type error = [ `No_enough_space ] 4 | 5 | let pp_error ppf = function 6 | | `No_enough_space -> Fmt.string ppf "No enough space" 7 | 8 | type 'err state = 9 | | Write of { buffer : string; off : int; len : int; continue : int -> 'err state; } 10 | | Error of 'err 11 | | Done 12 | 13 | let io_buffer_size = 65536 14 | 15 | let encoder () = { payload= Bytes.create io_buffer_size; pos= 0 } 16 | 17 | exception Leave of error 18 | 19 | let leave_with (_ : encoder) error = raise (Leave error) 20 | 21 | let safe 22 | : (unit -> ([> error ] as 'err) state) -> 'err state 23 | = fun k -> 24 | try k () with Leave (#error as err) -> Error (err : 'err) 25 | 26 | let flush k0 encoder = 27 | if encoder.pos > 0 28 | then 29 | let rec k1 n = if n < encoder.pos 30 | then Write { buffer= Bytes.unsafe_to_string encoder.payload; 31 | off= n; len= encoder.pos - n; continue= (fun m -> k1 (n + m)) } 32 | else ( encoder.pos <- 0 ; safe k0 ) in 33 | k1 0 34 | else safe k0 35 | 36 | let write str encoder = 37 | let max = Bytes.length encoder.payload in 38 | let go j l encoder = 39 | let rem = max - encoder.pos in 40 | let len = if l > rem then rem else l in 41 | Bytes.blit_string str j encoder.payload encoder.pos len ; 42 | encoder.pos <- encoder.pos + len ; 43 | if len < l then leave_with encoder `No_enough_space in 44 | go 0 (String.length str) encoder 45 | 46 | let blit ~buf ~off ~len encoder = 47 | let max = Bytes.length encoder.payload in 48 | let go j l encoder = 49 | let rem = max - encoder.pos in 50 | let len = if l > rem then rem else l in 51 | Bytes.blit_string buf (off + j) encoder.payload encoder.pos len ; 52 | encoder.pos <- encoder.pos + len ; 53 | if len < l then leave_with encoder `No_enough_space in 54 | go 0 len encoder 55 | 56 | type host = 57 | [ `Host of string 58 | | `Ip6 of Ipaddr.V6.t ] 59 | 60 | type t = 61 | [ `User of (string * string option * host option) | `Server of host ] option 62 | * string * (string list * string option) 63 | 64 | let write_crlf encoder = write "\r\n" encoder 65 | let write_space encoder = write " " encoder 66 | 67 | let write_host host encoder = match host with 68 | | `Host v -> write v encoder 69 | | `Ip6 v -> write (Ipaddr.V6.to_string v) encoder 70 | 71 | let write_prefix prefix encoder = match prefix with 72 | | `User (name, None, None) -> 73 | write ":" encoder ; 74 | write name encoder ; 75 | write_space encoder 76 | | `User (name, Some user, None) -> 77 | write ":" encoder ; 78 | write name encoder ; 79 | write "!" encoder ; 80 | write user encoder ; 81 | write_space encoder 82 | | `User (name, Some user, Some host) -> 83 | write ":" encoder ; 84 | write name encoder ; 85 | write "!" encoder ; 86 | write user encoder ; 87 | write "@" encoder ; 88 | write_host host encoder ; 89 | write_space encoder 90 | | `User (name, None, Some host) -> 91 | write ":" encoder ; 92 | write name encoder ; 93 | write "@" encoder ; 94 | write_host host encoder ; 95 | write_space encoder 96 | | `Server servername -> 97 | write ":" encoder ; 98 | write_host servername encoder ; 99 | write_space encoder 100 | 101 | let encode_line encoder = function 102 | | prefix, command, ([], None) -> 103 | Option.iter (fun prefix -> write_prefix prefix encoder) prefix ; 104 | write command encoder ; 105 | write_crlf encoder 106 | | prefix, command, (params, None) -> 107 | Option.iter (fun prefix -> write_prefix prefix encoder) prefix ; 108 | write command encoder ; 109 | List.iter (fun p -> write_space encoder ; write p encoder) params ; 110 | write_crlf encoder 111 | | prefix, command, ([], Some trailing) -> 112 | Option.iter (fun prefix -> write_prefix prefix encoder) prefix ; 113 | write command encoder ; 114 | write_space encoder ; 115 | write ":" encoder ; 116 | write trailing encoder ; 117 | write_crlf encoder 118 | | prefix, command, (params, Some trailing) -> 119 | Option.iter (fun prefix -> write_prefix prefix encoder) prefix ; 120 | write command encoder ; 121 | List.iter (fun p -> write_space encoder ; write p encoder) params ; 122 | write_space encoder ; 123 | write ":" encoder ; 124 | write trailing encoder ; 125 | write_crlf encoder 126 | 127 | let encode_line k encoder t = encode_line encoder t ; flush k encoder 128 | -------------------------------------------------------------------------------- /lib/protocol.mli: -------------------------------------------------------------------------------- 1 | type nick = { nick : Nickname.t; hopcount : int option; } 2 | 3 | type user = { username : string 4 | ; mode : int 5 | ; realname : string } 6 | 7 | type server = { servername : [ `raw ] Domain_name.t 8 | ; hopcount : int 9 | ; info : string } 10 | 11 | type oper = { user : string; password : string; } 12 | 13 | type notice = { dsts : Destination.t list; msg : string; } 14 | 15 | type 'a prettier = 16 | [ `Pretty of 'a | `String of string | `None ] 17 | 18 | type welcome = { nick : string; user : string; host : [ `raw ] Domain_name.t; } 19 | 20 | type discover = { users : int; services : int; servers : int; } 21 | 22 | type reply = 23 | { numeric : int 24 | ; params : string list * string option } 25 | 26 | type user_mode = 27 | { nickname : Nickname.t 28 | ; modes : User_mode.modes } 29 | 30 | type channel_mode = 31 | { channel : Channel.t 32 | ; modes : (Channel_mode.modes * string option) list } 33 | 34 | type names = 35 | { channel : Channel.t 36 | ; kind : [ `Secret | `Private | `Public ] 37 | ; names : ([ `Operator | `Voice | `None ] * Nickname.t) list } 38 | 39 | type host = 40 | [ `Host of [ `raw ] Domain_name.t 41 | | `Ip6 of Ipaddr.V6.t ] 42 | 43 | type mechanism = 44 | | PLAIN | LOGIN 45 | 46 | type prefix = 47 | | Server of host 48 | | User of { name : Nickname.t 49 | ; user : string option 50 | ; host : host option } 51 | 52 | type 'a t = 53 | | Pass : string t 54 | | Nick : nick t 55 | | User : user t 56 | | Server : server t 57 | | Oper : oper t 58 | | Quit : string t 59 | | SQuit : ([ `raw ] Domain_name.t * string) t 60 | | Join : (Channel.t * string option) list t 61 | | Notice : notice t 62 | | User_mode : user_mode t 63 | | Channel_mode : channel_mode t 64 | | Privmsg : (Destination.t list * string) t 65 | | Ping : ([ `raw ] Domain_name.t option * [ `raw ] Domain_name.t option) t 66 | | Pong : ([ `raw ] Domain_name.t option * [ `raw ] Domain_name.t option) t 67 | | Part : (Channel.t list * string option) t 68 | | Topic : (Channel.t * string option) t 69 | | Error : string option t 70 | | Authenticate : [ `Mechanism of mechanism | `Payload of string ] t 71 | | RPL_WELCOME : welcome prettier t 72 | | RPL_LUSERCLIENT : discover prettier t 73 | | RPL_YOURHOST : ([ `raw ] Domain_name.t * string) prettier t 74 | | RPL_CREATED : Ptime.t prettier t 75 | | RPL_MYINFO : string option (* TODO *) t 76 | | RPL_BOUNCE : string option (* TODO *) t 77 | | RPL_LUSEROP : int prettier t 78 | | RPL_LUSERUNKNOWN : int prettier t 79 | | RPL_LUSERCHANNELS : int prettier t 80 | | RPL_LUSERME : (int * int) prettier t 81 | | RPL_MOTDSTART : string option t 82 | | RPL_MOTD : string prettier t 83 | | RPL_ENDOFMOTD : string option t 84 | | RPL_TOPIC : (Channel.t * string) t 85 | | RPL_NOTOPIC : Channel.t t 86 | | RPL_NAMREPLY : names t 87 | | RPL_ENDOFNAMES : Channel.t t 88 | | ERR_NONICKNAMEGIVEN : unit t 89 | | ERR_NICKNAMEINUSE : Nickname.t t 90 | | ERR_NOTREGISTERED : unit t 91 | | RPL : reply t 92 | 93 | val pp_nick : nick Fmt.t 94 | val pp_user : user Fmt.t 95 | val pp_server : server Fmt.t 96 | val pp_oper : oper Fmt.t 97 | val pp_notice : notice Fmt.t 98 | val pp_prettier : 'a Fmt.t -> 'a prettier Fmt.t 99 | val pp_welcome : welcome Fmt.t 100 | val pp_discover : discover Fmt.t 101 | val pp_reply : reply Fmt.t 102 | val pp_user_mode : user_mode Fmt.t 103 | val pp_names : names Fmt.t 104 | val pp_host : host Fmt.t 105 | 106 | val pp_prefix : prefix Fmt.t 107 | 108 | type command = Command : 'a t -> command 109 | type message = Message : 'a t * 'a -> message 110 | type send = Send : 'a t * 'a -> send 111 | type 'a recv = 112 | | Recv : 'a t -> (prefix option * 'a) recv 113 | | Any : (prefix option * message) recv 114 | | Many : (prefix option * message) list recv 115 | 116 | val pp_message : message Fmt.t 117 | 118 | val prefix : ?user:string -> ?host:[ `raw ] Domain_name.t -> Nickname.t -> prefix 119 | val send : 'a t -> 'a -> send 120 | val recv : 'a t -> (prefix option * 'a) recv 121 | val any : (prefix option * message) recv 122 | val many : (prefix option * message) list recv 123 | 124 | val encode : ?prefix:prefix -> Encoder.encoder -> send -> [> Encoder.error ] Encoder.state 125 | 126 | type error = 127 | [ Decoder.error 128 | | `Invalid_command 129 | | `Invalid_parameters 130 | | `Invalid_reply ] 131 | 132 | val pp_error : error Fmt.t 133 | 134 | val decode : Decoder.decoder -> 'a recv -> ('a, error) Decoder.state 135 | -------------------------------------------------------------------------------- /bin/example.ml: -------------------------------------------------------------------------------- 1 | let reporter ppf = 2 | let report src level ~over k msgf = 3 | let k _ = 4 | over () ; 5 | k () in 6 | let with_metadata header _tags k ppf fmt = 7 | Format.kfprintf k ppf 8 | ("%a[%a]: " ^^ fmt ^^ "\n%!") 9 | Logs_fmt.pp_header (level, header) 10 | Fmt.(styled `Magenta string) 11 | (Logs.Src.name src) in 12 | msgf @@ fun ?header ?tags fmt -> with_metadata header tags k ppf fmt in 13 | { Logs.report } 14 | 15 | let ( <.> ) f g = fun x -> f (g x) 16 | 17 | let () = Printexc.record_backtrace true 18 | let () = Fmt_tty.setup_std_outputs ~style_renderer:`Ansi_tty ~utf_8:true () 19 | let () = Logs.set_reporter (reporter Fmt.stdout) 20 | let () = Logs.set_level ~all:true (Some Logs.Debug) 21 | let () = Random.self_init () 22 | let () = Mirage_crypto_rng_unix.initialize (module Mirage_crypto_rng.Fortuna) 23 | 24 | let hostname = Domain_name.of_string_exn (Unix.gethostname ()) 25 | 26 | let user = 27 | { Cri.Protocol.username= "mirage.noisy.bot" 28 | ; Cri.Protocol.mode= 0 29 | ; Cri.Protocol.realname= "A mirage noisy bot - https://github.com/dinosaure/cri" } 30 | 31 | let noisy_bot = Cri.Nickname.of_string_exn "noisy-bot" 32 | let mirage = Cri.Channel.of_string_exn "#mirage" 33 | let ocaml = Cri.Channel.of_string_exn "#ocaml" 34 | 35 | let host : [ `host ] Domain_name.t Mimic.value = Mimic.make ~name:"host" 36 | let port : int Mimic.value = Mimic.make ~name:"port" 37 | let inet_addr : Unix.inet_addr Mimic.value = Mimic.make ~name:"ipaddr" 38 | let sockaddr, tcpip = Mimic.register ~name:"tcp/ip" (module Socket) 39 | let cfg, _ = Mimic.register ~priority:10 ~name:"tls" (module Ttls) 40 | let tls : Tls.Config.client Mimic.value = Mimic.make ~name:"cfg" 41 | 42 | let gethostbyname host = 43 | match Unix.gethostbyname (Domain_name.to_string host) with 44 | | { Unix.h_addr_list; _ } when Array.length h_addr_list > 0 -> 45 | Lwt.return_some h_addr_list.(0) 46 | | _ -> Lwt.return_none 47 | | exception _ -> Lwt.return_none 48 | 49 | let make_tcp inet_addr port = 50 | Lwt.return_some (Unix.ADDR_INET (inet_addr, port)) 51 | 52 | let make_tls tls host sockaddr = Lwt.return_some (tls, host, sockaddr) 53 | 54 | let authenticator ?ip:_ ~host:_ _ = Ok None 55 | let default = Tls.Config.client ~authenticator () 56 | 57 | let ctx_of_uri uri = 58 | let ctx = Mimic.empty in 59 | match Uri.scheme uri with 60 | | Some "ircs" -> 61 | Mimic.add port (Option.value ~default:6697 (Uri.port uri)) ctx 62 | |> Mimic.fold sockaddr Mimic.Fun.[ req inet_addr; dft port 6697 ] ~k:make_tcp 63 | |> Mimic.fold inet_addr Mimic.Fun.[ req host ] ~k:gethostbyname 64 | |> Mimic.fold cfg Mimic.Fun.[ dft tls default; opt host; req sockaddr ] ~k:make_tls 65 | |> fun ctx -> 66 | let some v = 67 | try Mimic.add inet_addr (Unix.inet_addr_of_string v) ctx 68 | with _ -> Mimic.add host Domain_name.(host_exn (of_string_exn v)) ctx in 69 | Option.fold ~none:ctx ~some (Uri.host uri) 70 | | Some "irc" | None -> 71 | Mimic.add port (Option.value ~default:6667 (Uri.port uri)) ctx 72 | |> Mimic.fold sockaddr Mimic.Fun.[ req inet_addr; dft port 6667 ] ~k:make_tcp 73 | |> Mimic.fold inet_addr Mimic.Fun.[ req host; ] ~k:gethostbyname 74 | |> fun ctx -> 75 | let some v = 76 | try Mimic.add inet_addr (Unix.inet_addr_of_string v) ctx 77 | with _ -> Mimic.add host Domain_name.(host_exn (of_string_exn v)) ctx in 78 | Option.fold ~none:ctx ~some (Uri.host uri) 79 | | _ -> Fmt.invalid_arg "Invalid uri: %a" Uri.pp uri 80 | 81 | let sleep_ns = Lwt_unix.sleep <.> ( *. ) 1e-9 <.> Int64.to_float 82 | 83 | let log _msgs = Lwt.return_unit 84 | 85 | let timeout () = sleep_ns 256_000_000_000L 86 | 87 | let run ctx = 88 | let open Lwt.Infix in 89 | let stop = Lwt_switch.create () in 90 | let state = Cri_logger.state ~user ~channel:ocaml ~nickname:noisy_bot 91 | ~tick:1_000_000_000L log in 92 | let `Fiber th, recv, send, close = Cri_lwt.run ~timeout ~stop ctx in 93 | Lwt.both 94 | (th >>= fun res -> Lwt_switch.turn_off stop >|= close >>= fun () -> Lwt.return res) 95 | (Cri_logger.handler ~sleep_ns ~stop state recv send close) >>= function 96 | | Ok (), Ok () -> Lwt.return_unit 97 | | Error err, Ok () -> 98 | Fmt.epr "%a.\n%!" Cri_lwt.pp_error err ; 99 | Lwt.return_unit 100 | | Ok (), Error err -> 101 | Fmt.epr "%a.\n%!" Cri_logger.pp_error err ; 102 | Lwt.return_unit 103 | | Error err0, Error err1 -> 104 | Fmt.epr "%a.\n%!" Cri_lwt.pp_error err0 ; 105 | Fmt.epr "%a.\n%!" Cri_logger.pp_error err1 ; 106 | Lwt.return_unit 107 | 108 | let () = 109 | let ctx = ctx_of_uri (Uri.of_string Sys.argv.(1)) in 110 | Lwt_main.run (run ctx) 111 | -------------------------------------------------------------------------------- /unikernel/README.md: -------------------------------------------------------------------------------- 1 | ## How to use the unikernel? 2 | 3 | As a MirageOS project, you must install `opam` and `mirage` via: 4 | ```sh 5 | $ sudo apt install opam 6 | $ opam init 7 | $ opam install mirage 8 | ``` 9 | 10 | Then, you must _pin_ `cri` as an available package into your OPAM environment: 11 | ```sh 12 | $ git clone https://github.com/dinosaure/cri 13 | $ cd cri 14 | $ opam pin add -y . 15 | ``` 16 | 17 | Finally, you are able to compile the unikernel. For the unix target - the 18 | simpler one, you can do: 19 | ```sh 20 | $ cd unikernel 21 | $ mirage configure -t unix 22 | $ make depends 23 | $ mirage build 24 | $ ./logger --irc=ircs://irc.libera.chat:6697/ --remote=git@localhost:log.git \ 25 | --ssh-seed=$SEED --channel=#mirage --nickname=noisy-bot --nameserver=8.8.8.8 26 | ``` 27 | 28 | We integrate many way to communicate with a Git repository and SSH is one of 29 | them. You can look possibilities [here][ocaml-git-examples]. About SSH, you 30 | must have the "seed" of the RSA key. It's available via [`awa-ssh`][awa]: 31 | ```sh 32 | $ awa_gen_key 33 | seed is M0XGwihC6RtGCzYptLcHuO+SV38TqBUbCMiCf898 34 | ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQCmid+AGVt0mrVggEFkLAVS6rgWhhov+dw54Onm3L49BHYYPU4bz1Z4uIAmhGGvX/sfJ9KSYKr7PDncNi7EnvbeoGGBjNZM7GWKGji+jFZRwTWuamiJM/jL7NyRXb75bmOB1NT9NO42m0Z6BYnriOzm7dDl+3Hh3AqLpfwy2mg/6dlApcVgbGZTxpneY/vwMajtCikEXTyRmaXx0J2ceGCPt+i0R5MMGnEwPMmFsZF/J3juTp2dm/KG5eTcKOdXAs/WjwIv5W3vvDjwJUx5oxGugsUfgn+nHnX9EbqM4OeOlHwlG7l4Gp82PNRdhPFai1isFSDYFrXr7B5ZDnLWkXAx awa@awa.local 35 | ``` 36 | 37 | The seed is the first line and the public key is the second line. You just need 38 | to save the public key into your GitHub account or as an allowed key for the 39 | `git` Unix user. 40 | 41 | ## DNS nameserver 42 | 43 | Due to the design of IRC, the choice of the DNS server can be important due to 44 | the geographic position of your unikernel. It's why this parameter is required. 45 | Note that the DNS server used to communicate with the Git repository **is not** 46 | the same. The given nameserver is only used by the IRC client. 47 | 48 | ## Deploy on Gcloud 49 | 50 | It's possible to deploy the unikernel to `gcloud`. This is a mini-tutorial to 51 | deploy `cri-logger` on `gcloud`. Assume that you have a Gcloud project and the 52 | `gcloud` command-line available. You must have a GitHub repository and we will 53 | try to use SSH to let the unikernel to "push" logs on it. 54 | 55 | You must create an SSH key via `awa-ssh`: 56 | ```sh 57 | $ awa_gen_key 58 | seed is 59 | ssh-rsa ... awa@awa.local 60 | ``` 61 | 62 | The first line is the seed to regenerate the private RSA key. The second line 63 | is the public key which must be added to your GitHub account as an allowed SSH key. 64 | You must keep the SSH seed to configure the unikernel then: 65 | ```sh 66 | $ cd cri/unikernel 67 | $ mirage configure -t virtio --dhcp true --hostname cri \ 68 | --irc ircs://irc.libera.chat:6697/ \ 69 | --remote git@github.com:user/repository \ 70 | --nickname my-noisy-bot \ 71 | --channel="##mirage" \ 72 | --tick 86400 \ 73 | --nameserver 9.9.9.9 \ 74 | --ssh-seed 75 | ``` 76 | 77 | You can change any of these parameters. `tick` is how long we log the given channel, 78 | for instance, 1 day. `remote` is your GitHub repository and you can change 79 | `nickname` and `channel` as you want. You must copy the same `` given by 80 | `awa_gen_key`. Finally, you must choose the DNS server depending on the geographic 81 | position of your unikernel (your `gcloud` "region"). 82 | 83 | Now, you are able to compile the unikernel if you correctly `pin` `cri` with `opam`: 84 | ```sh 85 | $ make depends 86 | $ mirage build 87 | $ solo5-virtio-mkimage -f tar logger.tar.gz logger.virtio 88 | ``` 89 | 90 | We can start to deploy the unikernel then: 91 | ```sh 92 | $ gsutil mb gs://cri-logger 93 | $ gsutil cp logger.tar.gz gs://cri-logger 94 | $ gcloud compute images create cri-logger --source-uri gs://cri-logger/logger.tar.gz 95 | $ gcloud compute addresses create cri-logger --region europe-west1 96 | ``` 97 | 98 | You must take the IP address given by `gcloud` to be able then to create an instance: 99 | ```sh 100 | $ gcloud compute instances create cri-logger \ 101 | --image cri-logger \ 102 | --address \ 103 | --zone europe-west1-b \ 104 | --machine-type f1-micro \ 105 | ``` 106 | 107 | Et voilà! You will see in few second the bot on your channel and, in one day, the 108 | unikernel will push a new file on your GitHub repository. 109 | 110 | ## Bugs, bad state & improvements 111 | 112 | The unikernel is experimental and several issues exists if you give wrong 113 | arguments (such as a bad IRC address or a bad SSH key). In some situation, we 114 | can lost some messages. Indeed, `cri` does not implement the full version of 115 | the IRC protocol. 116 | 117 | [ocaml-git-examples]: https://github.com/mirage/ocaml-git/tree/master/unikernel/empty-commit 118 | [awa]: https://github.com/mirage/awa-ssh 119 | -------------------------------------------------------------------------------- /unikernel/unikernel.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | 3 | let msgs_to_string msgs = 4 | let rec go buf enc msgs = function 5 | | Cri.Encoder.Write { buffer; off; len; continue; } -> 6 | Buffer.add_substring buf buffer off len ; 7 | go buf enc msgs (continue len) 8 | | Cri.Encoder.Error _ -> assert false 9 | | Cri.Encoder.Done -> 10 | match msgs with 11 | | [] -> Buffer.contents buf 12 | | (p, Cri.Protocol.Message (t, v)) :: msgs -> 13 | go buf enc msgs Cri.Protocol.(encode enc ?prefix:p (send t v)) in 14 | match msgs with 15 | | [] -> "" 16 | | (p, Cri.Protocol.Message (t, v)) :: msgs -> 17 | let buf = Buffer.create 0x100 in 18 | let enc = Cri.Encoder.encoder () in 19 | go buf enc msgs Cri.Protocol.(encode enc ?prefix:p (send t v)) 20 | 21 | type config = 22 | { user : Cri.Protocol.user 23 | ; channel : Cri.Channel.t 24 | ; nickname : Cri.Nickname.t 25 | ; tick : int64 } 26 | 27 | module Make 28 | (Pclock : Mirage_clock.PCLOCK) 29 | (Time : Mirage_time.S) 30 | (_ : Mirage_stack.V4V6) 31 | (_ : sig end) 32 | (_ : sig end) = struct 33 | module Store = Irmin_mirage_git.Mem.KV (Irmin.Contents.String) 34 | module Sync = Irmin.Sync (Store) 35 | 36 | let info () = 37 | let d, ps = Pclock.now_d_ps () in 38 | let ptime = Ptime.v (d, ps) in 39 | Irmin.Info.v ~date:(Int64.of_float (Ptime.to_float_s ptime)) 40 | ~author:(Key_gen.nickname ()) 41 | (Fmt.str "log %a" Ptime.pp ptime) 42 | 43 | let config () = 44 | { user= { Cri.Protocol.username= "noisy-bot" 45 | ; mode= 0 46 | ; realname= "MirageOS noisy bot" } 47 | ; channel= Cri.Channel.of_string_exn (Key_gen.channel ()) 48 | ; nickname= Cri.Nickname.of_string_exn (Key_gen.nickname ()) 49 | ; tick= Int64.mul (Int64.of_int (Key_gen.tick ())) 1_000_000_000L } 50 | 51 | let save ~errored ctx uri msgs = 52 | let config = Irmin_mem.config () in 53 | Store.Repo.v config >>= Store.master >>= fun store -> 54 | let upstream = Store.remote ~ctx uri in 55 | Sync.pull ~depth:1 store upstream `Set >>= function 56 | | Error _ -> 57 | Logs.err (fun m -> m "Impossible to pull the remote Git repository.") ; 58 | Lwt_switch.turn_off errored 59 | | Ok (`Head _ | `Empty as parent) -> 60 | let parents = match parent with 61 | | `Head commit -> [ commit ] 62 | | `Empty -> [] in 63 | let now = Pclock.now_d_ps () |> Ptime.v in 64 | let k = [ Ptime.to_rfc3339 ~space:false ~tz_offset_s:0 now ] in 65 | let msgs = msgs_to_string msgs in 66 | Store.set ~parents ~info store k msgs >>= function 67 | | Error _ -> 68 | Logs.err (fun m -> m "Impossible to locally create a new commit.") ; 69 | Lwt_switch.turn_off errored 70 | | Ok () -> Sync.push store upstream >>= function 71 | | Ok `Empty -> Lwt.return_unit 72 | | Ok (`Head commit) -> 73 | Logs.debug (fun m -> m "New commit: %a" Store.Commit.pp_hash commit) ; 74 | Lwt.return_unit 75 | | Error _ -> 76 | Logs.err (fun m -> m "Impossible to push to the remote Git repository.") ; 77 | Lwt_switch.turn_off errored 78 | 79 | let log config ctx_irc ctx_git uri = 80 | let { user; channel; nickname; tick; } = config in 81 | let stop = Lwt_switch.create () in 82 | let errored = Lwt_switch.create () in 83 | let error, wk = Lwt.wait () in 84 | Lwt_switch.add_hook (Some errored) 85 | (fun () -> Lwt.wakeup_later wk `Error ; Lwt_switch.turn_off stop) ; 86 | let state = Cri_logger.state ~user ~channel ~nickname ~tick (save ~errored ctx_git uri) in 87 | let `Fiber th, recv, send, close = Cri_lwt.run ~stop 88 | ~timeout:(fun () -> Time.sleep_ns 256_000_000_000L) ctx_irc in 89 | Lwt.both 90 | (th >>= fun res -> Lwt_switch.turn_off stop >|= close >>= fun () -> Lwt.return res) 91 | (Cri_logger.handler ~sleep_ns:Time.sleep_ns ~stop state recv send close) >>= function 92 | | Ok (), Ok () -> 93 | ( match Lwt.state error with 94 | | Lwt.Sleep -> Lwt.cancel error ; Lwt.return `Stop 95 | | Lwt.Fail _ | Lwt.Return `Error -> 96 | Logs.warn (fun m -> m "The saver was errored, retry to log the IRC channel.") ; 97 | Lwt.return `Retry ) 98 | | Error err, _ -> 99 | Logs.err (fun m -> m "Got an error from the I/O thread: %a." Cri_lwt.pp_error err) ; 100 | Lwt.return `Retry 101 | | _, Error err -> 102 | Logs.err (fun m -> m "Got an error from the logic thread: %a." Cri_logger.pp_error err) ; 103 | Lwt.return `Retry 104 | 105 | let start () () _stack ctx_irc ctx_git = 106 | let config = config () in 107 | let ctx_irc = Mimic.merge ctx_irc (Cri_mirage.ctx_of_uri (Uri.of_string (Key_gen.irc ()))) in 108 | let rec infinite () = log config ctx_irc ctx_git (Key_gen.remote ()) >>= function 109 | | `Retry -> infinite () 110 | | `Stop -> Lwt.return_unit in 111 | infinite () 112 | end 113 | -------------------------------------------------------------------------------- /lib-mirage/cri_mirage.ml: -------------------------------------------------------------------------------- 1 | open Rresult 2 | open Lwt.Infix 3 | 4 | let src = Logs.Src.create "cri.mirage" 5 | module Log = (val Logs.src_log src : Logs.LOG) 6 | 7 | let ipaddr : Ipaddr.t Mimic.value = Mimic.make ~name:"cri-ipaddr" 8 | let domain_name : [ `host ] Domain_name.t Mimic.value = Mimic.make ~name:"cri-domain-name" 9 | let port : int Mimic.value = Mimic.make ~name:"cri-port" 10 | let cfg : Tls.Config.client Mimic.value = Mimic.make ~name:"cri-tls" 11 | let scheme : string Mimic.value = Mimic.make ~name:"cri-scheme" 12 | 13 | module Make 14 | (Random : Mirage_random.S) 15 | (Mclock : Mirage_clock.MCLOCK) 16 | (Pclock : Mirage_clock.PCLOCK) 17 | (Time : Mirage_time.S) 18 | (Stack : Tcpip.Stack.V4V6) = struct 19 | module TCP = struct 20 | include Stack.TCP 21 | 22 | type endpoint = Stack.t * Ipaddr.t * int 23 | 24 | type nonrec write_error = 25 | [ `Write of write_error | `Connect of error | `Closed ] 26 | 27 | let pp_write_error ppf = function 28 | | `Connect err -> pp_error ppf err 29 | | `Write err | (`Closed as err) -> pp_write_error ppf err 30 | 31 | let write flow cs = 32 | write flow cs >>= function 33 | | Ok _ as v -> Lwt.return v 34 | | Error err -> Lwt.return_error (`Write err) 35 | 36 | let writev flow css = 37 | writev flow css >>= function 38 | | Ok _ as v -> Lwt.return v 39 | | Error err -> Lwt.return_error (`Write err) 40 | 41 | let connect : endpoint -> _ = fun (stack, ipaddr, port) -> 42 | let stack = Stack.tcp stack in 43 | create_connection stack (ipaddr, port) >>= function 44 | | Ok _ as v -> Lwt.return v 45 | | Error err -> Lwt.return_error (`Connect err) 46 | end 47 | 48 | module TLS = struct 49 | let src = Logs.Src.create "cri.mirage.tls" 50 | module Log = (val Logs.src_log src : Logs.LOG) 51 | 52 | 53 | include Tls_mirage.Make (TCP) 54 | 55 | type endpoint = Tls.Config.client * [ `host ] Domain_name.t option * Stack.t * Ipaddr.t * int 56 | 57 | let connect (cfg, host, stack, ipaddr, port) = 58 | Log.debug (fun m -> m "Try to initiate a TLS connection to %a:%d (%a)." 59 | Ipaddr.pp ipaddr port Fmt.(option Domain_name.pp) host) ; 60 | TCP.connect (stack, ipaddr, port) >>= function 61 | | Ok flow -> client_of_flow cfg ?host flow 62 | | Error err -> Lwt.return_error (`Write err) 63 | end 64 | 65 | let tcp_edn, _tcp_protocol = Mimic.register ~name:"cri-tcpip" (module TCP) 66 | let tls_edn, _tcp_protocol = Mimic.register ~priority:10 ~name:"cri-tls" (module TLS) 67 | 68 | let stack : Stack.t Mimic.value = Mimic.make ~name:"cri-stack" 69 | let with_stack v ctx = Mimic.add stack v ctx 70 | 71 | module DNS = Dns_client_mirage.Make (Random) (Time) (Mclock) (Pclock) (Stack) 72 | 73 | let dns : DNS.t Mimic.value = Mimic.make ~name:"cri-dns" 74 | let with_dns ?cache_size ?nameservers ?timeout v ctx = 75 | let v = DNS.create ?cache_size ?nameservers ?timeout v in 76 | Mimic.add dns v ctx 77 | 78 | let authenticator ?ip:_ ~host:_ _ = Ok None 79 | 80 | let ctx = 81 | let k0 scheme stack ipaddr port = match scheme with 82 | | "irc" -> Lwt.return_some (stack, ipaddr, port) 83 | | _ -> Lwt.return_none in 84 | let k1 cfg domain_name stack ipaddr port = 85 | Lwt.return_some (cfg, domain_name, stack, ipaddr, port) in 86 | let k2 dns domain_name = 87 | Log.debug (fun m -> m "Try to resolve %a." Domain_name.pp domain_name) ; 88 | DNS.gethostbyname dns domain_name >>= function 89 | | Ok ipv4 -> 90 | Log.debug (fun m -> m "DNS: %a -> %a." Domain_name.pp domain_name Ipaddr.V4.pp ipv4) ; 91 | Lwt.return_some (Ipaddr.V4 ipv4) 92 | | _ -> 93 | Log.warn (fun m -> m "No IPv4 found for %a." Domain_name.pp domain_name) ; 94 | Lwt.return_none in 95 | Mimic.empty 96 | |> Mimic.fold tcp_edn Mimic.Fun.[ req scheme; req stack; req ipaddr; dft port 6665 ] ~k:k0 97 | |> Mimic.fold tls_edn Mimic.Fun.[ dft cfg (Tls.Config.client ~authenticator ()) 98 | ; opt domain_name 99 | ; req stack 100 | ; req ipaddr 101 | ; dft port 6697 ] ~k:k1 102 | |> Mimic.fold ipaddr Mimic.Fun.[ req dns; req domain_name ] ~k:k2 103 | end 104 | 105 | let ( <.> ) f g = fun x -> f (g x) 106 | 107 | let ctx_of_uri uri = 108 | let ctx = Mimic.empty in 109 | let ctx = Option.fold ~none:ctx ~some:(fun v -> Mimic.add scheme v ctx) (Uri.scheme uri) in 110 | let ctx = match Uri.host uri with 111 | | None -> ctx 112 | | Some host -> match R.(Domain_name.of_string host >>= Domain_name.host), Ipaddr.of_string host with 113 | | _, Ok v -> Mimic.add ipaddr v ctx 114 | | Ok v, _ -> Mimic.add domain_name v ctx 115 | | _ -> ctx in 116 | let ctx = Option.fold ~none:ctx ~some:(fun v -> Mimic.add port v ctx) (Uri.port uri) in 117 | ctx 118 | -------------------------------------------------------------------------------- /lib-logger/cri_logger.ml: -------------------------------------------------------------------------------- 1 | let src = Logs.Src.create "cri-lwt" 2 | module Log = (val Logs.src_log src : Logs.LOG) 3 | 4 | module Atomic = struct 5 | type 'a t = { mutable v : 'a } 6 | 7 | let make v = {v} 8 | let get r = r.v 9 | let set r v = r.v <- v 10 | end 11 | 12 | type state = 13 | { step : step Atomic.t 14 | ; queue : (Cri.Protocol.prefix option * Cri.Protocol.message) Queue.t 15 | ; user : Cri.Protocol.user 16 | ; channel : Cri.Channel.t 17 | ; nickname : Cri.Nickname.t 18 | ; mutex : Lwt_mutex.t 19 | ; log : (Cri.Protocol.prefix option * Cri.Protocol.message) list -> unit Lwt.t 20 | ; tick : int64 } 21 | and step = 22 | | Connected 23 | | Send_nick of [ `Done | `Errored ] 24 | | Send_user of [ `Done | `Errored ] 25 | | Join of [ `In_progress | `Done | `Errored ] 26 | | Log 27 | 28 | (* XXX(dinosaure): see RFC 2812, 3.1 - Connection Registration 29 | The recommended order for a client to register is as follows: 30 | 1. Pass message 31 | 2. Nick message | 2. Service message 32 | 3. User message 33 | *) 34 | 35 | let state ~user ~channel ~nickname ~tick log = 36 | { step= Atomic.make Connected 37 | ; queue= Queue.create () 38 | ; user; channel; nickname 39 | ; mutex= Lwt_mutex.create () 40 | ; log; tick; } 41 | 42 | type join_error = 43 | [ `Need_more_params 44 | | `Invite_only_chan 45 | | `Channel_is_full 46 | | `No_such_channel 47 | | `Too_many_targets 48 | | `Banned_from_chan 49 | | `Bad_channel_key 50 | | `Bad_chan_mask 51 | | `Too_many_channels 52 | | `Unavailable_resource ] 53 | 54 | type user_error = 55 | [ `Need_more_params 56 | | `Already_registered ] 57 | 58 | type nick_error = 59 | [ `No_nickname_given 60 | | `Nickname_in_use 61 | | `Unavailable_resource 62 | | `Nick_collision 63 | | `Restricted ] 64 | 65 | exception Join of join_error 66 | exception User of user_error 67 | exception Nick of nick_error 68 | 69 | type error = [ join_error | user_error | nick_error ] 70 | 71 | let pp_error : error Fmt.t = fun ppf -> function 72 | | `Need_more_params -> Fmt.pf ppf "Need more params" 73 | | `Invite_only_chan -> Fmt.pf ppf "Invite only chan" 74 | | `Channel_is_full -> Fmt.pf ppf "Channel is full" 75 | | `No_such_channel -> Fmt.pf ppf "No such channel" 76 | | `Too_many_targets -> Fmt.pf ppf "Too many targets" 77 | | `Banned_from_chan -> Fmt.pf ppf "Banned from chan" 78 | | `Bad_channel_key -> Fmt.pf ppf "Bad channel key" 79 | | `Bad_chan_mask -> Fmt.pf ppf "Bad chan mask" 80 | | `Too_many_channels -> Fmt.pf ppf "Too many channels" 81 | | `Unavailable_resource -> Fmt.pf ppf "Unavailable resource" 82 | | `Already_registered -> Fmt.pf ppf "Already registered" 83 | | `No_nickname_given -> Fmt.pf ppf "No nickname given" 84 | | `Nickname_in_use -> Fmt.pf ppf "Nickname in use" 85 | | `Nick_collision -> Fmt.pf ppf "Nick collision" 86 | | `Restricted -> Fmt.pf ppf "Restricted" 87 | 88 | let rec writer state closed ({ Cri_lwt.send } as ssend) = 89 | let open Lwt.Infix in 90 | Lwt.pick [ closed; (Lwt.pause () >|= fun () -> `Continue) ] >>= function 91 | | `Closed -> Lwt.return_unit 92 | | `Continue -> match Atomic.get state.step with 93 | | Connected -> 94 | Log.debug (fun m -> m "Connected, send nick -> Send_nick `Done") ; 95 | send Cri.Protocol.Nick { Cri.Protocol.nick= state.nickname; hopcount= None; } ; 96 | Atomic.set state.step (Send_nick `Done) ; 97 | writer state closed ssend 98 | | Join `In_progress -> 99 | writer state closed ssend 100 | | Send_user `Done -> 101 | Log.debug (fun m -> m "Send_user `Done, send join -> Join `In_progress") ; 102 | send Cri.Protocol.Join [ state.channel, None ] ; 103 | Atomic.set state.step (Join `In_progress) ; 104 | writer state closed ssend 105 | | Send_nick `Done -> 106 | Log.debug (fun m -> m "Send_nick `Done, send user -> Send_user `Done") ; 107 | send Cri.Protocol.User state.user ; 108 | Atomic.set state.step (Send_user `Done) ; 109 | writer state closed ssend 110 | | Join `Done | Log -> 111 | Log.debug (fun m -> m "Join `Done | Log, terminate the application writer.") ; 112 | Atomic.set state.step Log ; 113 | Lwt.return_unit 114 | | Join `Errored | Send_user `Errored | Send_nick `Errored -> 115 | Log.warn (fun m -> m "Got a state error.") ; 116 | Lwt.return_unit (* TODO(dinosaure): retry? *) 117 | 118 | let rec reader state recv ({ Cri_lwt.send } as ssend) = 119 | let open Lwt.Infix in 120 | Lwt.pause () >>= recv >>= fun v -> match v, Atomic.get state.step with 121 | | None, _ -> Lwt.return_unit 122 | | Some (_, Cri.Protocol.Message (RPL_TOPIC, (ch, topic))), Join (`In_progress | `Done) -> 123 | Log.info (fun m -> m "%a: %s" Cri.Channel.pp ch topic) ; 124 | Log.debug (fun m -> m "Start to save %a" Cri.Channel.pp ch) ; 125 | Atomic.set state.step (Join `Done) ; 126 | reader state recv ssend 127 | | Some (_, Cri.Protocol.Message (ERR_NONICKNAMEGIVEN, _)), 128 | (Send_nick `Done | Send_user `Done | Join `In_progress) -> 129 | Atomic.set state.step (Send_nick `Errored) ; 130 | reader state recv ssend 131 | | Some (_, Cri.Protocol.Message (Ping, v)), _ -> 132 | Log.debug (fun m -> m "Ping -> Pong") ; 133 | send Cri.Protocol.Pong v ; 134 | reader state recv ssend 135 | | Some (prefix, msg), Log -> 136 | Lwt_mutex.with_lock state.mutex @@ begin fun () -> 137 | Queue.push (prefix, msg) state.queue ; Lwt.return_unit end >>= fun () -> 138 | reader state recv ssend 139 | | Some _, _ -> reader state recv ssend 140 | 141 | let rec drain queue = go [] queue 142 | and go acc queue = match Queue.pop queue with 143 | | msg -> go (msg :: acc) queue 144 | | exception Queue.Empty -> acc 145 | 146 | let rec tick ~sleep_ns state closed = 147 | let open Lwt.Infix in 148 | sleep_ns state.tick >>= fun () -> 149 | Lwt_mutex.with_lock state.mutex @@ begin fun () -> 150 | let lst = drain state.queue in Lwt.return (List.rev lst) end >>= fun lst -> 151 | Log.debug (fun m -> m "Call the logger with %d msg(s)." (List.length lst)) ; 152 | Lwt.async 153 | (fun () -> Lwt.catch (fun () -> state.log lst) 154 | (fun exn -> Log.err (fun m -> m "Got an exception from the logger: %s." (Printexc.to_string exn)) 155 | ; Lwt.return_unit ) ) ; 156 | Lwt.pick [ closed; (Lwt.pause () >|= fun () -> `Continue) ] >>= function 157 | | `Closed -> Lwt.return_unit 158 | | `Continue -> tick ~sleep_ns state closed 159 | 160 | let handler ~sleep_ns ~stop state recv send close = 161 | let open Lwt.Infix in 162 | let closed, u = Lwt.wait () in 163 | Lwt_switch.add_hook (Some stop) 164 | (fun () -> Lwt.wakeup_later u `Closed ; close () ; Lwt.return_unit) ; 165 | Lwt.catch 166 | (fun () -> 167 | Lwt.join [ reader state recv send 168 | ; writer state closed send 169 | ; tick ~sleep_ns state closed ] >>= fun () -> 170 | Lwt.return_ok ()) 171 | @@ function 172 | | Join err -> Lwt_switch.turn_off stop >>= fun () -> Lwt.return_error (err :> error) 173 | | Nick err -> Lwt_switch.turn_off stop >>= fun () -> Lwt.return_error (err :> error) 174 | | User err -> Lwt_switch.turn_off stop >>= fun () -> Lwt.return_error (err :> error) 175 | | exn -> raise exn 176 | -------------------------------------------------------------------------------- /lib-lwt/cri_lwt.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | open Cri 3 | 4 | let src = Logs.Src.create "cri-lwt" 5 | module Log = (val Logs.src_log src : Logs.LOG) 6 | 7 | let pp_error ppf = function 8 | | `Write err -> Mimic.pp_write_error ppf err 9 | | `Decoder err -> Decoder.pp_error_with_info ~pp:Protocol.pp_error ppf err 10 | | `End_of_input -> Fmt.string ppf "End of input" 11 | | `Time_out -> Fmt.string ppf "time out" 12 | | #Encoder.error as err -> Encoder.pp_error ppf err 13 | | #Mimic.error as err -> Mimic.pp_error ppf err 14 | 15 | let blit0 src src_off dst dst_off len = 16 | let src = Cstruct.to_bigarray src in 17 | Bigstringaf.blit src ~src_off dst ~dst_off ~len 18 | 19 | let blit1 src src_off dst dst_off len = 20 | Bigstringaf.blit_to_bytes src ~src_off dst ~dst_off ~len 21 | 22 | type reader_error = 23 | [ `End_of_input 24 | | `Decoder of Protocol.error Decoder.info 25 | | `Time_out 26 | | Mimic.error ] 27 | 28 | type writer_error = [ `Write of Mimic.write_error | Encoder.error ] 29 | 30 | type error = [ reader_error | writer_error ] 31 | 32 | type signal = 33 | [ Cstruct.t Mirage_flow.or_eof 34 | | `Continue | `Stop | `Timeout ] 35 | 36 | let pause_and_continue () = 37 | Lwt.pause () >|= fun () -> `Continue 38 | 39 | let launch_timeout ~timeout = 40 | timeout () >|= fun () -> Result.ok `Timeout 41 | 42 | let try_to_read flow = 43 | Mimic.read flow >|= fun res -> (res :> (signal, _) result) 44 | 45 | let rec reader ?stop ~timeout ~push flow = 46 | let dec = Decoder.decoder () in 47 | let ke = Ke.Rke.create ~capacity:0x1000 Bigarray.char in 48 | let th, u = Lwt.wait () in 49 | Lwt.catch begin fun () -> 50 | Lwt_switch.add_hook_or_exec stop (fun () -> Lwt.wakeup_later u `Stop ; Lwt.return_unit) >>= fun () -> 51 | Log.debug (fun m -> m "Launch the reader.") ; 52 | go ~stop:th ~timeout ~push dec ke flow (Protocol.decode dec Protocol.Any) 53 | end @@ fun exn -> 54 | Log.err (fun m -> m "Got an exception from the reader loop: %S." (Printexc.to_string exn)) ; 55 | push None ; Lwt.return_ok () 56 | and go ~stop ~timeout ~push dec ke flow = function 57 | | Decoder.Done (_committed, msg) -> 58 | ( try push (Some msg) with _ -> () ) ; 59 | Log.debug (fun m -> m "Pause and waiting message.") ; 60 | ( Lwt.pick [ pause_and_continue () 61 | ; stop ] >>= function 62 | | `Continue -> go ~stop ~timeout ~push dec ke flow (Protocol.decode dec Protocol.Any) 63 | | `Stop -> push None ; Lwt.return_ok () ) 64 | | Decoder.Read { buffer; off; len; continue; } as state -> 65 | Log.debug (fun m -> m "Read the flow.") ; 66 | ( match Ke.Rke.N.peek ke with 67 | | [] -> 68 | ( Lwt.pick [ try_to_read flow 69 | ; (stop >|= fun v -> Result.ok (v :> signal)) 70 | ; launch_timeout ~timeout ] >>= function 71 | | Error err -> 72 | Log.err (fun m -> m "Got an error while reading on the flow: %a." Mimic.pp_error err) ; 73 | Lwt.return_error (err :> error) 74 | | Ok `Continue -> 75 | assert false (* XXX(dinosaure): it's safe! *) 76 | | Ok `Timeout -> 77 | Log.debug (fun m -> m "The client time-out on the reader.") ; 78 | push None ; Lwt.return_error `Time_out 79 | | Ok `Stop -> 80 | Log.debug (fun m -> m "The client wants to close the connection.") ; 81 | push None ; Lwt.return_ok () 82 | | Ok `Eof -> 83 | Log.debug (fun m -> m "The connection was closed by peer.") ; 84 | push None ; Lwt.return_error `End_of_input 85 | | Ok (`Data cs) -> 86 | Log.debug (fun m -> m "<~ @[%a@]" (Hxd_string.pp Hxd.default) (Cstruct.to_string cs)) ; 87 | Ke.Rke.N.push ke ~blit:blit0 ~length:Cstruct.length ~off:0 ~len:(Cstruct.length cs) cs ; 88 | go ~stop ~timeout ~push dec ke flow state ) 89 | | _ -> 90 | let len = min len (Ke.Rke.length ke) in 91 | Ke.Rke.N.keep_exn ke ~blit:blit1 ~length:Bytes.length ~off ~len buffer ; 92 | Ke.Rke.N.shift_exn ke len ; 93 | go ~stop ~timeout ~push dec ke flow (continue len) ) 94 | | Decoder.Error err -> 95 | Log.err (fun m -> m "%a." pp_error (`Decoder err)) ; 96 | push None ; Lwt.return_error (`Decoder err) 97 | 98 | let ( >>? ) = Lwt_result.bind 99 | 100 | let rec writer ~timeout ~next flow = 101 | let enc = Encoder.encoder () in 102 | let tmp = Cstruct.create Decoder.io_buffer_size in 103 | let allocator len = Cstruct.sub tmp 0 len in 104 | Lwt.pause () >>= next >>= function 105 | | Some (prefix, send) -> 106 | go ~timeout ~next allocator enc flow (Protocol.encode ?prefix enc send) 107 | | None -> 108 | Log.debug (fun m -> m "End of the writer.") ; 109 | Lwt.return_ok () 110 | and go ~timeout ~next allocator enc flow = function 111 | | Encoder.Done -> 112 | Log.debug (fun m -> m "Pause and next operation to emit.") ; 113 | ( Lwt.pause () >>= next >>= function 114 | | Some (prefix, send) -> 115 | go ~timeout ~next allocator enc flow (Protocol.encode ?prefix enc send) 116 | | None -> 117 | Log.debug (fun m -> m "Terminate the writer.") ; 118 | Lwt.return_ok () ) 119 | | Encoder.Write { buffer; off; len; continue; } -> 120 | let cs = Cstruct.of_string ~allocator ~off ~len buffer in 121 | Log.debug (fun m -> m "~> @[%a@]" (Hxd_string.pp Hxd.default) (Cstruct.to_string cs)) ; 122 | ( Lwt.pick [ (Mimic.write flow cs >>? fun () -> Lwt.return_ok `Done) 123 | ; (timeout () >>= fun () -> Lwt.return_ok `Time_out) ] >>= function 124 | | Ok `Time_out -> 125 | Log.err (fun m -> m "The client time-out on the writer") ; 126 | Lwt.return_error `Time_out 127 | | Ok `Done -> go ~timeout ~next allocator enc flow (continue len) 128 | | Error err -> 129 | Log.err (fun m -> m "Got an error while writing on the flow: %a." Mimic.pp_write_error err) ; 130 | Lwt.return_error (`Write err) ) 131 | | Encoder.Error err -> Lwt.return_error (err :> error) 132 | 133 | let ( >>? ) = Lwt_result.bind 134 | 135 | type recv = unit -> (Cri.Protocol.prefix option * Cri.Protocol.message) option Lwt.t 136 | type send = { send : 'a. ?prefix:Cri.Protocol.prefix -> 'a Cri.Protocol.t -> 'a -> unit } [@@unboxed] 137 | type close = unit -> unit 138 | 139 | let run ?(connected= Fun.const Lwt.return_unit) ?stop ?timeout ctx = 140 | let timeout = match timeout with 141 | | Some timeout -> timeout 142 | | None -> let never, _ = Lwt.wait () in fun () -> never in 143 | let recv, push_recv = Lwt_stream.create () in 144 | let send, push_send = Lwt_stream.create () in 145 | let push_send v = try push_send v with _ -> () in 146 | `Fiber 147 | (Mimic.resolve ctx >>? fun flow -> 148 | connected () >>= fun () -> 149 | Log.debug (fun m -> m "Connected to the IRC server.") ; 150 | Lwt.pick 151 | [ reader ?stop ~timeout ~push:(fun v -> try push_recv v with _ -> ()) flow 152 | ; writer ~timeout ~next:(fun () -> Lwt_stream.get send) flow ] >>= fun res -> 153 | Log.debug (fun m -> m "Reader or writer are resolved (with an error: %b)." (Rresult.R.is_error res)) ; 154 | (* XXX(dinosaure): with TLS, [Mimic.close] can time-out. *) 155 | Lwt.pick [ Mimic.close flow; timeout () ] >>= fun () -> match res with 156 | | Ok () -> Lwt.return_ok () 157 | | Error err -> 158 | Log.err (fun m -> m "Got an error: %a." pp_error err) ; 159 | Lwt.return_error (err :> error)), 160 | (fun () -> Lwt_stream.get recv), 161 | { send= (fun ?prefix w v -> push_send (Some (prefix, Protocol.send w v))) }, 162 | (fun () -> push_send None) 163 | -------------------------------------------------------------------------------- /lib/decoder.ml: -------------------------------------------------------------------------------- 1 | type decoder = { buffer : bytes; mutable pos : int; mutable max : int } 2 | 3 | let io_buffer_size = 65536 4 | 5 | let decoder () = { buffer= Bytes.create io_buffer_size; pos= 0; max= 0; } 6 | 7 | let decoder_from x = 8 | let max = String.length x in 9 | let buffer = Bytes.of_string x in 10 | { buffer; pos= 0; max } 11 | 12 | type error = [ `End_of_input | `Expected_eol | `Expected_line | `Invalid_line of string ] 13 | 14 | let pp_error ppf = function 15 | | `End_of_input -> Fmt.string ppf "End of input" 16 | | `Expected_eol -> Fmt.string ppf "Expected End-Of-Line" 17 | | `Expected_line -> Fmt.string ppf "Expected a line" 18 | | `Invalid_line line -> Fmt.pf ppf "Invalid line: %S" line 19 | 20 | type 'err info = { error : 'err; buffer : bytes; committed : int; max : int; } 21 | 22 | let pp_error_with_info ~pp ppf { error; buffer; committed; max; } = 23 | let str = Bytes.sub_string buffer committed (max - committed) in 24 | Fmt.pf ppf "Decoding error: %a: @[%a@]" 25 | pp error (Hxd_string.pp Hxd.default) str 26 | 27 | exception Leave of error info 28 | 29 | let leave_with (decoder : decoder) error = 30 | raise (Leave { error; buffer= decoder.buffer; committed= decoder.pos; max= decoder.max; }) 31 | 32 | type ('v, 'err) state = 33 | | Done of int * 'v 34 | | Read of { buffer : Bytes.t 35 | ; off : int; len : int 36 | ; continue : int -> ('v, 'err) state } 37 | | Error of 'err info 38 | 39 | let return decoder v = Done (decoder.pos, v) 40 | 41 | let at_least_one_line (decoder : decoder) = 42 | let pos = ref decoder.pos in 43 | let chr = ref '\000' in 44 | let has_cr = ref false in 45 | while !pos < decoder.max && ( chr := Bytes.unsafe_get decoder.buffer !pos ; 46 | not (!chr = '\n' && !has_cr) ) 47 | do has_cr := !chr = '\r' ; incr pos done ; 48 | !pos < decoder.max && !chr = '\n' && !has_cr 49 | 50 | let safe : 51 | (decoder -> ('v, [> error ] as 'err) state) -> decoder -> ('v, 'err) state 52 | = fun k decoder -> 53 | try k decoder with Leave { error= #error as error; buffer; committed; max; } -> 54 | Error { error= (error :> 'err); buffer; committed; max; } 55 | 56 | let rec prompt 57 | : k:(decoder -> ('v, ([> error ] as 'err)) state) 58 | -> decoder -> ('v, 'err) state 59 | = fun ~k decoder -> 60 | if decoder.pos > 0 61 | then ( let rest = decoder.max - decoder.pos in 62 | Bytes.unsafe_blit decoder.buffer decoder.pos decoder.buffer 0 rest ; 63 | decoder.max <- rest ; 64 | decoder.pos <- 0 ) ; 65 | go ~k decoder decoder.max 66 | and go ~k decoder off = 67 | if off = Bytes.length decoder.buffer 68 | && not (at_least_one_line { decoder with max= off }) 69 | then 70 | ( Fmt.epr ">>> @[%a@]\n%!" (Hxd_string.pp Hxd.default) 71 | (Bytes.sub_string decoder.buffer decoder.pos (off - decoder.pos)) 72 | ; assert false ) 73 | else if not (at_least_one_line { decoder with max = off }) 74 | then Read { buffer= decoder.buffer; off; len= Bytes.length decoder.buffer - off; 75 | continue= (fun len -> go ~k decoder (off + len)); } 76 | else ( decoder.max <- off ; safe k decoder ) 77 | 78 | let peek_while_eol decoder = 79 | let idx = ref decoder.pos in 80 | let chr = ref '\000' in 81 | let has_cr = ref false in 82 | while !idx < decoder.max && ( chr := Bytes.unsafe_get decoder.buffer !idx ; 83 | not (!chr = '\n' && !has_cr) ) 84 | do has_cr := !chr == '\r' ; incr idx done ; 85 | if !idx < decoder.max && !chr = '\n' && !has_cr 86 | then (decoder.buffer, decoder.pos, !idx + 1 - decoder.pos) 87 | else leave_with decoder `Expected_eol 88 | 89 | module BNF = struct 90 | open Angstrom 91 | 92 | let is_digit = function 93 | | '0' .. '9' -> true 94 | | _ -> false 95 | 96 | (* XXX(dinosaure): currently, we handle '*' which is not described by the RFC but 97 | freenode don't tell us the fully qualified domain-name and uses [*.freenode.net]. *) 98 | let name = peek_char >>= function 99 | | None | Some ('a' .. 'z' | 'A' .. 'Z' | '*') -> 100 | ( take_while1 @@ function 101 | | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '-' | '*' -> true 102 | | _ -> false ) >>= fun str -> 103 | if str.[String.length str - 1] = '-' 104 | then fail "name" 105 | else return str 106 | | _ -> fail "name" 107 | 108 | let ip6addr = 109 | take_while1 is_digit >>= fun x -> 110 | count 7 (char ':' *> take_while1 is_digit) >>= fun r -> 111 | let ipv6 = String.concat ":" (x :: r) in 112 | try return (Ipaddr.V6.of_string_exn ipv6) 113 | with _ -> fail "ip6addr" 114 | 115 | let host = name >>= fun x -> many (char '.' *> name) >>= fun r -> return (x :: r) 116 | let host = 117 | (host >>| String.concat "." >>| fun v -> `Host v) 118 | <|> (ip6addr >>| fun v -> `Ip6 v) 119 | 120 | let servername = host 121 | 122 | let is_letter = function 123 | | 'a' .. 'z' | 'A' .. 'Z' -> true 124 | | _ -> false 125 | 126 | let is_number = function 127 | | '0' .. '9' -> true 128 | | _ -> false 129 | 130 | let is_special = function 131 | | '-' | '[' | ']' | '\\' | '`' | '^' | '{' | '}' (* TODO *) | '_' -> true 132 | | _ -> false 133 | 134 | let is_space = (=) ' ' 135 | 136 | let is_non_white = function 137 | | '\x20' | '\x00' | '\x0d' | '\x0a' -> false 138 | | _ -> true 139 | 140 | let user = take_while1 is_non_white 141 | 142 | let ( || ) f g = fun chr -> f chr || g chr 143 | 144 | let nick = 145 | satisfy (is_letter || (* TODO *) ((=) '_')) >>= fun chr -> 146 | take_while (is_letter || is_number || is_special) >>= fun str -> 147 | return (String.make 1 chr ^ str) 148 | 149 | let prefix = 150 | choice 151 | [ (nick >>= fun who -> 152 | option None (char '!' *> user >>| Option.some) >>= fun user -> 153 | option None (char '@' *> host >>| Option.some) >>= fun host -> 154 | take_while1 is_space *> 155 | return (`User (who, user, host))) 156 | ; (servername <* take_while1 is_space >>= fun v -> 157 | return (`Server v)) ] 158 | 159 | let for_all p str = 160 | let res = ref true in 161 | String.iter (fun chr -> res := !res && p chr) str ; !res 162 | 163 | let trailing = take_while @@ function 164 | | '\x00' | '\r' | '\n' -> false 165 | | _ -> true 166 | 167 | let failf fmt = Fmt.kstr fail fmt 168 | 169 | let command = 170 | (take_while1 is_letter) 171 | <|> (take 3 >>= fun str -> if for_all is_number str then return str else failf "command %S" str) 172 | 173 | let middle = 174 | peek_char >>= function 175 | | None | Some ':' -> fail "middle" 176 | | _ -> take_while1 @@ function 177 | | '\x00' | ' ' | '\r' | '\n' -> false 178 | | _ -> true 179 | 180 | let params = 181 | many (take_while1 is_space *> middle) <* take_while is_space >>= fun params -> 182 | peek_char >>= function 183 | | Some ':' -> char ':' *> trailing >>= fun v -> return (params, Some v) 184 | | _ -> return (params, None) 185 | 186 | let crlf = string "\r\n" 187 | 188 | let message = 189 | option None (char ':' *> prefix >>= fun v -> return (Some v)) >>= fun prefix -> 190 | (command "command") >>= fun command -> 191 | (params "params") >>= fun params -> 192 | return (prefix, command, params) <* crlf 193 | end 194 | 195 | let junk_eol decoder = 196 | let idx = ref decoder.pos in 197 | let chr = ref '\000' in 198 | let has_cr = ref false in 199 | while !idx < decoder.max && ( chr := Bytes.unsafe_get decoder.buffer !idx ; 200 | not (!chr = '\n' && !has_cr) ) 201 | do has_cr := !chr == '\r' ; incr idx done ; 202 | if !idx < decoder.max && !chr = '\n' && !has_cr 203 | then decoder.pos <- !idx + 1 204 | else leave_with decoder `Expected_eol 205 | 206 | type host = 207 | [ `Host of string 208 | | `Ip6 of Ipaddr.V6.t ] 209 | 210 | type t = 211 | [ `User of (string* string option * host option) | `Server of host ] option 212 | * string * (string list * string option) 213 | 214 | let peek_line ~k decoder = 215 | let k decoder = 216 | let (buffer, off, len) = peek_while_eol decoder in 217 | let str = Bytes.sub_string buffer off len in 218 | match Angstrom.parse_string ~consume:All BNF.message str with 219 | | Ok v -> k v decoder 220 | | Error _ -> 221 | let line = String.sub str 0 (String.length str - 2) in 222 | decoder.pos <- decoder.pos + len ; 223 | leave_with decoder (`Invalid_line line) in 224 | prompt ~k decoder 225 | 226 | let leave_with (decoder : decoder) error = 227 | Error { error; buffer= decoder.buffer; committed= decoder.pos; max= decoder.max; } 228 | 229 | let rec bind x f = match x with 230 | | Done (_, v) -> f v 231 | | Read { buffer; off; len; continue; } -> 232 | let continue len = bind (continue len) f in 233 | Read { buffer; off; len; continue; } 234 | | Error err -> Error err 235 | 236 | let rec reword_error f = function 237 | | Done (committed, v) -> Done (committed, v) 238 | | Read { buffer; off; len; continue; } -> 239 | let continue len = reword_error f (continue len) in 240 | Read { buffer; off; len; continue; } 241 | | Error ({ error; _ } as info) -> Error { info with error = (f error) } 242 | -------------------------------------------------------------------------------- /unikernel/config.ml: -------------------------------------------------------------------------------- 1 | open Mirage 2 | 3 | type mimic = Mimic 4 | let mimic = typ Mimic 5 | 6 | let empty = 7 | let packages = [ package "mimic" ] in 8 | impl @@ object 9 | inherit base_configurable 10 | method ty = mimic 11 | method module_name = "Mimic" 12 | method! packages = Key.pure packages 13 | method name = "mimic_ctx" 14 | method! connect _ _modname _ = "Lwt.return Mimic.empty" 15 | end 16 | 17 | let mimic_count = 18 | let v = ref (-1) in 19 | fun () -> incr v ; !v 20 | 21 | let mimic_conf () = 22 | let packages = [ package "mimic" ] in 23 | impl @@ object 24 | inherit base_configurable 25 | method ty = mimic @-> mimic @-> mimic 26 | method module_name = "Mimic.Merge" 27 | method! packages = Key.pure packages 28 | method name = Fmt.str "merge_ctx%02d" (mimic_count ()) 29 | method! connect _ _modname = 30 | function 31 | | [ a; b ] -> Fmt.str "Lwt.return (Mimic.merge %s %s)" a b 32 | | [ x ] -> Fmt.str "%s.ctx" x 33 | | _ -> Fmt.str "Lwt.return Mimic.empty" 34 | end 35 | 36 | let merge ctx0 ctx1 = mimic_conf () $ ctx0 $ ctx1 37 | 38 | let mimic_tcp_conf = 39 | let packages = [ package "git-mirage" ~sublibs:[ "tcp" ] ] in 40 | impl @@ object 41 | inherit base_configurable 42 | method ty = stackv4v6 @-> mimic 43 | method module_name = "Git_mirage_tcp.Make" 44 | method! packages = Key.pure packages 45 | method name = "tcp_ctx" 46 | method! connect _ modname = function 47 | | [ stack ] -> 48 | Fmt.str {ocaml|Lwt.return (%s.with_stack %s %s.ctx)|ocaml} 49 | modname stack modname 50 | | _ -> assert false 51 | end 52 | 53 | let mimic_tcp_impl stackv4v6 = mimic_tcp_conf $ stackv4v6 54 | 55 | let mimic_ssh_conf ~kind ~seed ~auth = 56 | let seed = Key.abstract seed in 57 | let auth = Key.abstract auth in 58 | let packages = [ package "git-mirage" ~sublibs:[ "ssh" ] ] in 59 | impl @@ object 60 | inherit base_configurable 61 | method ty = stackv4v6 @-> mimic @-> mclock @-> mimic 62 | method! keys = [ seed; auth; ] 63 | method module_name = "Git_mirage_ssh.Make" 64 | method! packages = Key.pure packages 65 | method name = match kind with 66 | | `Rsa -> "ssh_rsa_ctx" 67 | | `Ed25519 -> "ssh_ed25519_ctx" 68 | method! connect _ modname = 69 | function 70 | | [ _; tcp_ctx; _ ] -> 71 | let with_key = 72 | match kind with 73 | | `Rsa -> "with_rsa_key" 74 | | `Ed25519 -> "with_ed25519_key" 75 | in 76 | Fmt.str 77 | {ocaml|let ssh_ctx00 = Mimic.merge %s %s.ctx in 78 | let ssh_ctx01 = Option.fold ~none:ssh_ctx00 79 | ~some:(fun v -> %s.%s v ssh_ctx00) %a in 80 | let ssh_ctx02 = Option.fold ~none:ssh_ctx01 81 | ~some:(fun v -> %s.with_authenticator v ssh_ctx01) %a in 82 | Lwt.return ssh_ctx02|ocaml} 83 | tcp_ctx modname 84 | modname with_key Key.serialize_call seed 85 | modname Key.serialize_call auth 86 | | _ -> assert false 87 | end 88 | 89 | let mimic_ssh_impl ~kind ~seed ~auth stackv4v6 mimic_git mclock = 90 | mimic_ssh_conf ~kind ~seed ~auth 91 | $ stackv4v6 92 | $ mimic_git 93 | $ mclock 94 | 95 | let mimic_dns_conf ~nameserver = 96 | let packages = [ package "git-mirage" ~sublibs:[ "dns" ] ] in 97 | let nameserver = Key.abstract nameserver in 98 | impl @@ object 99 | inherit base_configurable 100 | method ty = random @-> mclock @-> time @-> stackv4v6 @-> mimic @-> mimic 101 | method module_name = "Git_mirage_dns.Make" 102 | method! packages = Key.pure packages 103 | method! keys = [ nameserver ] 104 | method name = "dns_ctx" 105 | method! connect _ modname = 106 | function 107 | | [ _; _; _; stack; tcp_ctx ] -> 108 | Fmt.str 109 | {ocaml|let dns_ctx00 = Mimic.merge %s %s.ctx in 110 | let dns_ctx01 = %s.with_dns ~nameserver:(`TCP, (%a, 53)) %s dns_ctx00 in 111 | Lwt.return dns_ctx01|ocaml} 112 | tcp_ctx modname 113 | modname Key.serialize_call nameserver stack 114 | | _ -> assert false 115 | end 116 | 117 | let mimic_dns_impl ~nameserver random mclock time stackv4v6 mimic_tcp = 118 | mimic_dns_conf ~nameserver $ random $ mclock $ time $ stackv4v6 $ mimic_tcp 119 | 120 | type paf = Paf 121 | let paf = typ Paf 122 | 123 | let paf_conf () = 124 | let packages = [ package "paf" ~sublibs:[ "mirage" ] ] in 125 | impl @@ object 126 | inherit base_configurable 127 | method ty = time @-> stackv4v6 @-> paf 128 | method module_name = "Paf_mirage.Make" 129 | method! packages = Key.pure packages 130 | method name = "paf" 131 | end 132 | 133 | let paf_impl time stackv4v6 = paf_conf () $ time $ stackv4v6 134 | 135 | let mimic_paf_conf () = 136 | let packages = [ package "git-paf" ] in 137 | impl @@ object 138 | inherit base_configurable 139 | method ty = time @-> pclock @-> stackv4v6 @-> paf @-> mimic @-> mimic 140 | method module_name = "Git_paf.Make" 141 | method! packages = Key.pure packages 142 | method name = "paf_ctx" 143 | method! connect _ modname = function 144 | | [ _; _; _; _; tcp_ctx; ] -> 145 | Fmt.str 146 | {ocaml|let paf_ctx00 = Mimic.merge %s %s.ctx in 147 | Lwt.return paf_ctx00|ocaml} 148 | tcp_ctx modname 149 | | _ -> assert false 150 | end 151 | 152 | let mimic_paf_impl time pclock stackv4v6 paf mimic_tcp = 153 | mimic_paf_conf () 154 | $ time 155 | $ pclock 156 | $ stackv4v6 157 | $ paf 158 | $ mimic_tcp 159 | 160 | let mimic_cri_conf ~nameserver () = 161 | let packages = [ package ~sublibs:[ "mirage" ] "cri" ] in 162 | let nameserver = Key.abstract nameserver in 163 | impl @@ object 164 | inherit base_configurable 165 | method ty = random @-> mclock @-> time @-> stackv4v6 @-> mimic 166 | method module_name = "Cri_mirage.Make" 167 | method! packages = Key.pure packages 168 | method! keys = [ nameserver ] 169 | method name = "cri_ctx" 170 | method! connect _ modname = function 171 | | [ _; _; _; stack; ] -> 172 | Fmt.str {ocaml|let cri_ctx00 = %s.with_stack %s %s.ctx in 173 | let cri_ctx01 = %s.with_dns ~nameserver:(`TCP, (%a, 53)) %s cri_ctx00 in 174 | Lwt.return cri_ctx01|ocaml} 175 | modname stack modname 176 | modname Key.serialize_call nameserver stack 177 | | _ -> assert false 178 | end 179 | 180 | let mimic_cri_impl ~nameserver random mclock time stackv4v6 = 181 | mimic_cri_conf ~nameserver () $ random $ mclock $ time $ stackv4v6 182 | 183 | (* / *) 184 | 185 | let ssh_seed = 186 | let doc = Key.Arg.info ~doc:"Seed of the private SSH key." [ "ssh-seed" ] in 187 | Key.(create "ssh_seed" Arg.(opt (some string) None doc)) 188 | 189 | let ssh_auth = 190 | let doc = Key.Arg.info ~doc:"SSH public key of the remote Git endpoint." [ "ssh-auth" ] in 191 | Key.(create "ssh_auth" Arg.(opt (some string) None doc)) 192 | 193 | let hostname = 194 | let doc = Key.Arg.info ~doc:"Hostname of the bot." [ "hostname" ] in 195 | Key.(create "hostname" Arg.(required string doc)) 196 | 197 | let nickname = 198 | let doc = Key.Arg.info ~doc:"Nickname of the bot." [ "nickname" ] in 199 | Key.(create "nickname" Arg.(opt string "noisy-bot" doc)) 200 | 201 | let channel = 202 | let doc = Key.Arg.info ~doc:"IRC channel to log." [ "channel" ] in 203 | Key.(create "channel" Arg.(required string doc)) 204 | 205 | let tick = 206 | let doc = Key.Arg.info ~doc:"How long we log the channel (in seconds)." [ "tick" ] in 207 | Key.(create "tick" Arg.(opt int 3600 doc)) 208 | 209 | let remote = 210 | let doc = Key.Arg.info ~doc:"Git repository to save logs." [ "remote" ] in 211 | Key.(create "remote" Arg.(required string doc)) 212 | 213 | let irc = 214 | let doc = Key.Arg.info ~doc:"IRC server to connect." [ "irc" ] in 215 | Key.(create "irc" Arg.(required string doc)) 216 | 217 | let nameserver = 218 | let doc = Key.Arg.info ~doc:"DNS server used to resolve domain-name." [ "nameserver" ] in 219 | Key.(create "nameserver" Arg.(required ip_address doc)) 220 | 221 | let logger = 222 | foreign "Unikernel.Make" 223 | ~keys:[ Key.abstract hostname 224 | ; Key.abstract nickname 225 | ; Key.abstract channel 226 | ; Key.abstract tick 227 | ; Key.abstract remote 228 | ; Key.abstract irc ] 229 | (pclock @-> time @-> stackv4v6 @-> mimic @-> mimic @-> job) 230 | 231 | let git ~kind ~seed ~auth ~nameserver stackv4v6 random mclock pclock time paf = 232 | let mtcp = mimic_tcp_impl stackv4v6 in 233 | let mdns = mimic_dns_impl ~nameserver random mclock time stackv4v6 mtcp in 234 | let mssh = mimic_ssh_impl ~kind ~seed ~auth stackv4v6 mtcp mclock in 235 | let mpaf = mimic_paf_impl time pclock stackv4v6 paf mtcp in 236 | merge mpaf (merge mssh mdns) 237 | 238 | let random = default_random 239 | let stackv4v6 = generic_stackv4v6 default_network 240 | let pclock = default_posix_clock 241 | let mclock = default_monotonic_clock 242 | let time = default_time 243 | 244 | let paf = paf_impl time stackv4v6 245 | let git = git ~kind:`Rsa ~seed:ssh_seed ~auth:ssh_auth ~nameserver 246 | let git = git stackv4v6 random mclock pclock time paf 247 | 248 | let irc = mimic_cri_impl ~nameserver random mclock time stackv4v6 249 | 250 | let () = 251 | register "logger" 252 | ~packages:[ package "cri" ~sublibs:[ "lwt"; "logger" ] 253 | ; package "irmin-mirage-git" ] 254 | [ logger $ pclock $ time $ stackv4v6 $ irc $ git ] 255 | -------------------------------------------------------------------------------- /lib/protocol.ml: -------------------------------------------------------------------------------- 1 | let src = Logs.Src.create "cri.protocol" 2 | 3 | module Log = (val Logs.src_log src : Logs.LOG) 4 | 5 | type nick = { nick : Nickname.t; hopcount : int option; } 6 | 7 | type user = { username : string 8 | ; mode : int 9 | ; realname : string } 10 | 11 | type server = { servername : [ `raw ] Domain_name.t 12 | ; hopcount : int 13 | ; info : string } 14 | 15 | type oper = { user : string; password : string; } 16 | 17 | type notice = { dsts : Destination.t list; msg : string; } 18 | 19 | type 'a prettier = 20 | [ `Pretty of 'a | `String of string | `None ] 21 | 22 | type welcome = { nick : string; user : string; host : [ `raw ] Domain_name.t; } 23 | 24 | type discover = { users : int; services : int; servers : int; } 25 | 26 | type reply = 27 | { numeric : int 28 | ; params : string list * string option } 29 | 30 | type user_mode = 31 | { nickname : Nickname.t 32 | ; modes : User_mode.modes } 33 | 34 | type channel_mode = 35 | { channel : Channel.t 36 | ; modes : (Channel_mode.modes * string option) list } 37 | 38 | type names = 39 | { channel : Channel.t 40 | ; kind : [ `Secret | `Private | `Public ] 41 | ; names : ([ `Operator | `Voice | `None ] * Nickname.t) list } 42 | 43 | type host = 44 | [ `Host of [ `raw ] Domain_name.t 45 | | `Ip6 of Ipaddr.V6.t ] 46 | 47 | let pp_nick ppf { nick; hopcount; } = match hopcount with 48 | | Some hopcount -> Fmt.pf ppf "%a (hopcount: %d)" Nickname.pp nick hopcount 49 | | None -> Nickname.pp ppf nick 50 | 51 | let pp_user ppf { username; mode; realname; } = 52 | Fmt.pf ppf "%s %d (%s)" 53 | username mode realname 54 | 55 | let pp_server ppf { servername; hopcount; info; } = 56 | Fmt.pf ppf "%a:%d (%s)" Domain_name.pp servername hopcount info 57 | 58 | let pp_oper ppf { user; password= _; } = 59 | Fmt.pf ppf "%s" user 60 | 61 | let pp_notice ppf { dsts; msg; } = 62 | Fmt.pf ppf "%a: %s" Fmt.(Dump.list Destination.pp) dsts msg 63 | 64 | let pp_prettier pp ppf = function 65 | | `Pretty v -> pp ppf v 66 | | `String v -> Fmt.pf ppf "%S" v 67 | | `None -> () 68 | 69 | let pp_welcome ppf { nick; user; host; } = 70 | Fmt.pf ppf "%s!%s@%a" nick user Domain_name.pp host 71 | 72 | let pp_discover ppf { users; services; servers; } = 73 | Fmt.pf ppf "users:%d, services: %d, servers:%d" users services servers 74 | 75 | let pp_reply ppf { numeric; params= ps, r; } = match ps, r with 76 | | _ :: _, Some r -> Fmt.pf ppf "%03d %a :%s" numeric Fmt.(list ~sep:(any "@ ") string) ps r 77 | | _ :: _, None -> Fmt.pf ppf "%03d %a" numeric Fmt.(list ~sep:(any "@ ") string) ps 78 | | [], Some r -> Fmt.pf ppf "%03d :%s" numeric r 79 | | [], None -> Fmt.pf ppf "%03d" numeric 80 | 81 | let pp_user_mode ppf { nickname; modes; } = 82 | Fmt.pf ppf "%a %a" Nickname.pp nickname User_mode.pp modes 83 | 84 | let pp_names ppf { channel; kind; names; } = 85 | let pp_name ppf (k, nickname) = match k with 86 | | `Operator -> Fmt.pf ppf "@%a" Nickname.pp nickname 87 | | `Voice -> Fmt.pf ppf "+%a" Nickname.pp nickname 88 | | `None -> Nickname.pp ppf nickname in 89 | match kind with 90 | | `Secret -> Fmt.pf ppf "@%a %a" Channel.pp channel Fmt.(Dump.list pp_name) names 91 | | `Private -> Fmt.pf ppf "*%a %a" Channel.pp channel Fmt.(Dump.list pp_name) names 92 | | `Public -> Fmt.pf ppf "=%a %a" Channel.pp channel Fmt.(Dump.list pp_name) names 93 | 94 | let pp_host ppf = function 95 | | `Host v -> Domain_name.pp ppf v 96 | | `Ip6 v -> Ipaddr.V6.pp ppf v 97 | 98 | type prefix = 99 | | Server of host 100 | | User of { name : Nickname.t 101 | ; user : string option 102 | ; host : host option } 103 | 104 | let pp_prefix ppf (prefix : prefix) = match prefix with 105 | | Server host -> pp_host ppf host 106 | | User { name; user; host; } -> 107 | Fmt.pf ppf "%a%a%a" 108 | Nickname.pp name 109 | Fmt.(option ((const string "!") ++ string)) user 110 | Fmt.(option ((const string "@") ++ pp_host)) host 111 | 112 | type mechanism = 113 | | PLAIN | LOGIN 114 | 115 | let pp_mechanism ppf = function 116 | | PLAIN -> Fmt.string ppf "PLAIN" 117 | | LOGIN -> Fmt.string ppf "LOGIN" 118 | 119 | module Fun = struct 120 | type ('k, 'res) args = 121 | | [] : ('res, 'res) args 122 | | ( :: ) : 'a arg * ('k, 'res) args -> ('a -> 'k, 'res) args 123 | and 'v arg = .. 124 | 125 | type 'v arg += Int : int arg 126 | type 'v arg += String : string arg 127 | end 128 | 129 | type 'a t = 130 | | Pass : string t 131 | | Nick : nick t 132 | | User : user t 133 | | Server : server t 134 | | Oper : oper t 135 | | Quit : string t 136 | | SQuit : ([ `raw ] Domain_name.t * string) t 137 | | Join : (Channel.t * string option) list t 138 | | Notice : notice t 139 | | User_mode : user_mode t 140 | | Channel_mode : channel_mode t 141 | | Privmsg : (Destination.t list * string) t 142 | | Ping : ([ `raw ] Domain_name.t option * [ `raw ] Domain_name.t option) t 143 | | Pong : ([ `raw ] Domain_name.t option * [ `raw ] Domain_name.t option) t 144 | | Part : (Channel.t list * string option) t 145 | | Topic : (Channel.t * string option) t 146 | | Error : string option t 147 | | Authenticate : [ `Mechanism of mechanism | `Payload of string ] t 148 | | RPL_WELCOME : welcome prettier t 149 | | RPL_LUSERCLIENT : discover prettier t 150 | | RPL_YOURHOST : ([ `raw ] Domain_name.t * string) prettier t 151 | | RPL_CREATED : Ptime.t prettier t 152 | | RPL_MYINFO : string option (* TODO *) t 153 | | RPL_BOUNCE : string option (* TODO *) t 154 | | RPL_LUSEROP : int prettier t 155 | | RPL_LUSERUNKNOWN : int prettier t 156 | | RPL_LUSERCHANNELS : int prettier t 157 | | RPL_LUSERME : (int * int) prettier t 158 | | RPL_MOTDSTART : string option t 159 | | RPL_MOTD : string prettier t 160 | | RPL_ENDOFMOTD : string option t 161 | | RPL_TOPIC : (Channel.t * string) t 162 | | RPL_NOTOPIC : Channel.t t 163 | | RPL_NAMREPLY : names t 164 | | RPL_ENDOFNAMES : Channel.t t 165 | | ERR_NONICKNAMEGIVEN : unit t 166 | | ERR_NICKNAMEINUSE : Nickname.t t 167 | | ERR_NOTREGISTERED : unit t 168 | | RPL : reply t 169 | 170 | type command = Command : 'a t -> command 171 | type message = Message : 'a t * 'a -> message 172 | 173 | let command_of_line (_, command, parameters) = match String.lowercase_ascii command with 174 | | "pass" -> Ok (Command Pass) 175 | | "nick" -> Ok (Command Nick) 176 | | "user" -> Ok (Command User) 177 | | "server" -> Ok (Command Server) 178 | | "oper" -> Ok (Command Oper) 179 | | "quit" -> Ok (Command Quit) 180 | | "squit" -> Ok (Command SQuit) 181 | | "notice" -> Ok (Command Notice) 182 | | "join" -> Ok (Command Join) 183 | | "mode" -> ( match parameters with 184 | | v :: _, _ -> 185 | if Channel.is v 186 | then Ok (Command Channel_mode) 187 | else if Nickname.is v 188 | then Ok (Command User_mode) 189 | else Rresult.R.error_msgf "Unknown command: %S" command 190 | | _ -> Rresult.R.error_msgf "Unknown command: %S" command ) 191 | | "privmsg" -> Ok (Command Privmsg) 192 | | "ping" -> Ok (Command Ping) 193 | | "pong" -> Ok (Command Pong) 194 | | "part" -> Ok (Command Part) 195 | | "topic" -> Ok (Command Topic) 196 | | "error" -> Ok (Command Error) 197 | | "authenticate" -> Ok (Command Authenticate) 198 | | "001" -> Ok (Command RPL_WELCOME) 199 | | "002" -> Ok (Command RPL_YOURHOST) 200 | | "003" -> Ok (Command RPL_CREATED) 201 | | "004" -> Ok (Command RPL_MYINFO) 202 | | "005" -> Ok (Command RPL_BOUNCE) 203 | | "251" -> Ok (Command RPL_LUSERCLIENT) 204 | | "252" -> Ok (Command RPL_LUSEROP) 205 | | "253" -> Ok (Command RPL_LUSERUNKNOWN) 206 | | "254" -> Ok (Command RPL_LUSERCHANNELS) 207 | | "255" -> Ok (Command RPL_LUSERME) 208 | | "250" | "265" | "266" | "333" -> Ok (Command RPL) 209 | | "375" -> Ok (Command RPL_MOTDSTART) 210 | | "372" -> Ok (Command RPL_MOTD) 211 | | "376" -> Ok (Command RPL_ENDOFMOTD) 212 | | "331" -> Ok (Command RPL_NOTOPIC) 213 | | "332" -> Ok (Command RPL_TOPIC) 214 | | "353" -> Ok (Command RPL_NAMREPLY) 215 | | "366" -> Ok (Command RPL_ENDOFNAMES) 216 | | "431" -> Ok (Command ERR_NONICKNAMEGIVEN) 217 | | "433" -> Ok (Command ERR_NICKNAMEINUSE) 218 | | "451" -> Ok (Command ERR_NOTREGISTERED) 219 | | code -> 220 | Log.warn (fun m -> m "Got an unknown command %S" code); 221 | ( try let _ = int_of_string code in Ok (Command RPL) 222 | with _ -> Rresult.R.error_msgf "Unknown command: %S" command ) 223 | 224 | type send = Send : 'a t * 'a -> send 225 | 226 | type 'a recv = 227 | | Recv : 'a t -> (prefix option * 'a) recv 228 | | Any : (prefix option * message) recv 229 | | Many : (prefix option * message) list recv 230 | 231 | let to_prefix : prefix option -> _ = function 232 | | Some (User { name; user; host= Some (`Host host); }) -> 233 | Some (`User (Nickname.to_string name, user, Some (`Host (Domain_name.to_string host)))) 234 | | Some (User { name; user; host= Some (`Ip6 host); }) -> 235 | Some (`User (Nickname.to_string name, user, Some (`Ip6 host))) 236 | | Some (User { name; user; host= None; }) -> 237 | Some (`User (Nickname.to_string name, user, None)) 238 | | Some (Server (`Host v)) -> Some (`Server (`Host (Domain_name.to_string v))) 239 | | Some (Server (`Ip6 v)) -> Some (`Server (`Ip6 v)) 240 | | None -> None 241 | 242 | let of_prettier pp = function 243 | | `Pretty v -> Some (Fmt.str "%a" pp v) 244 | | `String str -> Some str 245 | | `None -> None 246 | 247 | let identity x = x 248 | 249 | let scanner_of_reply 250 | : type k r. r prettier t -> (k, r) Fun.args -> ((k, _, _, _, _, r) format6 * k) option 251 | = fun w args -> match w, args with 252 | | RPL_LUSERCHANNELS, Fun.[ Int ] -> 253 | Some ("%d channel(s) formed" ^^ "", identity) 254 | | RPL_LUSERME, Fun.[ Int; Int ] -> 255 | Some ("I have %d clients and %d servers" ^^ "", (fun a b -> (a, b))) 256 | | RPL_MOTD, Fun.[ String ] -> 257 | Some ("- %s" ^^ "", identity) 258 | | _ -> None 259 | 260 | let to_prettier 261 | : type a. a prettier t -> string list * string option -> a prettier 262 | = fun t params -> match t, params with 263 | | RPL_LUSERCHANNELS, ([], Some msg) -> 264 | let scanner = scanner_of_reply t Fun.[ Int ] in 265 | ( match Option.map (fun (scanner, k) -> Scanf.sscanf msg scanner k) scanner with 266 | | Some v -> `Pretty v | None -> `String msg | exception _ -> `String msg) 267 | | RPL_LUSERME, ([], Some msg) -> 268 | let scanner = scanner_of_reply t Fun.[ Int; Int ] in 269 | ( match Option.map (fun (scanner, k) -> Scanf.sscanf msg scanner k) scanner with 270 | | Some v -> `Pretty v | None -> `String msg | exception _ -> `String msg) 271 | | RPL_MOTD, ([], Some msg) -> 272 | let scanner = scanner_of_reply t Fun.[ String ] in 273 | ( match Option.map (fun (scanner, k) -> Scanf.sscanf msg scanner k) scanner with 274 | | Some v -> `Pretty v | None -> `String msg | exception _ -> `String msg) 275 | | _, (_, Some msg) -> `String msg 276 | | _, (_, None) -> `None 277 | 278 | let to_line 279 | : type a. ?prefix:prefix -> a t -> a -> Encoder.t 280 | = fun ?prefix w v -> match w, v with 281 | | Pass, v -> to_prefix prefix, "pass", ([ v ], None) 282 | | Nick, { nick; hopcount= None; } -> 283 | to_prefix prefix, "nick", ([ Nickname.to_string nick ], None) 284 | | Nick, { nick; hopcount= Some hopcount; } -> 285 | to_prefix prefix, "nick", ([ Nickname.to_string nick; string_of_int hopcount ], None) 286 | | User, { username; mode; realname; } -> 287 | to_prefix prefix, "user", ([ username; string_of_int mode; "*"; ], Some realname) 288 | | Server, { servername; hopcount; info; } -> 289 | let servername = Domain_name.to_string servername in 290 | to_prefix prefix, "server", ([ servername; string_of_int hopcount; ], Some info) 291 | | Oper, { user; password; } -> 292 | to_prefix prefix, "oper", ([ user; password; ], None) 293 | | Quit, msg -> 294 | to_prefix prefix, "quit", ([], Some msg) 295 | | SQuit, (server, msg) -> 296 | let server = Domain_name.to_string server in 297 | to_prefix prefix, "squit", ([ server ], Some msg) 298 | | Notice, { dsts; msg; } -> 299 | let dsts = List.map Destination.to_string dsts in 300 | let dsts = String.concat "," dsts in 301 | to_prefix prefix, "notice", ([ dsts ], Some msg) 302 | | Join, channels -> 303 | let channels, keys = List.split channels in 304 | let keys, _ = List.partition Option.is_some keys in 305 | let keys = List.map Option.get keys in 306 | let channels = List.map Channel.to_string channels in 307 | let channels = String.concat "," channels in 308 | let keys = String.concat "," keys in 309 | to_prefix prefix, "join", ([ channels; keys; ], None) 310 | | User_mode, { nickname; modes; } -> 311 | to_prefix prefix, "mode", ([ Nickname.to_string nickname ], Some (User_mode.to_string modes)) 312 | | Channel_mode, { channel; modes; } -> 313 | let rec parameters acc = function 314 | | [] -> List.rev acc 315 | | (modes, None) :: tl -> parameters (Channel_mode.to_string modes :: acc) tl 316 | | (modes, Some v) :: tl -> parameters (v :: Channel_mode.to_string modes :: acc) tl in 317 | to_prefix prefix, "mode", (parameters [ Channel.to_string channel ] modes, None) 318 | | Privmsg, (dsts, msg) -> 319 | let dsts = List.map Destination.to_string dsts in 320 | let dsts = String.concat "," dsts in 321 | to_prefix prefix, "privmsg", ([ dsts ], Some msg) 322 | | Ping, (src, dst) -> 323 | ( match src, dst with 324 | | Some src, None -> to_prefix prefix, "ping", ([ Domain_name.to_string src ], None) 325 | | None, Some dst -> to_prefix prefix, "ping", ([], Some (Domain_name.to_string dst)) 326 | | Some src, Some dst -> 327 | to_prefix prefix, "ping", ([ Domain_name.to_string src; Domain_name.to_string dst ], None) 328 | | None, None -> assert false (* TODO *) ) 329 | | Pong, (src, dst) -> 330 | ( match src, dst with 331 | | Some src, None -> to_prefix prefix, "pong", ([ Domain_name.to_string src ], None) 332 | | None, Some dst -> to_prefix prefix, "pong", ([], Some (Domain_name.to_string dst)) 333 | | Some src, Some dst -> 334 | to_prefix prefix, "pong", ([ Domain_name.to_string src; Domain_name.to_string dst ], None) 335 | | None, None -> assert false (* TODO *) ) 336 | | Part, (channels, msg) -> 337 | let channels = String.concat "," (List.map Channel.to_string channels) in 338 | to_prefix prefix, "part", ([ channels ], msg) 339 | | Topic, (channel, topic) -> 340 | to_prefix prefix, "topic", ([ Channel.to_string channel ], topic) 341 | | Error, msg -> 342 | to_prefix prefix, "error", ([], msg) 343 | | Authenticate, `Mechanism mechanism -> 344 | to_prefix prefix, "authenticate", ([ Fmt.str "%a" pp_mechanism mechanism ], None) 345 | | Authenticate, `Payload str -> 346 | to_prefix prefix, "authenticate", ([ str ], None) 347 | | RPL_WELCOME, v -> 348 | let param = match v with 349 | | `Pretty { nick; _ } -> [ nick ] 350 | | _ -> [] in 351 | let pp ppf { nick; user; host; } = 352 | Fmt.pf ppf "Welcome to the Cri Internet Relay Network %s!%s@%a" 353 | nick user Domain_name.pp host in 354 | to_prefix prefix, "001", (param, of_prettier pp v) 355 | | RPL_YOURHOST, v -> 356 | let pp ppf (servername, version) = 357 | Fmt.pf ppf "Your host is %a, running version %s" 358 | Domain_name.pp servername version in 359 | to_prefix prefix, "002", ([], of_prettier pp v) 360 | | RPL_CREATED, v -> 361 | let pp = Ptime.pp_rfc3339 ~space:false () in (* XXX(dinosaure): time-zone? *) 362 | to_prefix prefix, "003", ([], of_prettier pp v) 363 | | RPL_MYINFO, msg -> 364 | to_prefix prefix, "004", ([], msg) 365 | | RPL_BOUNCE, msg -> 366 | to_prefix prefix, "005", ([], msg) 367 | | RPL_LUSERCLIENT, v -> 368 | let pp ppf { users; services; servers; } = 369 | Fmt.pf ppf "There are %d users and %d services and %d servers" 370 | users services servers in 371 | to_prefix prefix, "251", ([], of_prettier pp v) 372 | | RPL_LUSEROP, v -> 373 | let pp ppf operators = Fmt.pf ppf "%d operator(s) online" operators in 374 | to_prefix prefix, "252", ([], of_prettier pp v) 375 | | RPL_LUSERUNKNOWN, v -> 376 | let pp ppf unknown_connections = 377 | Fmt.pf ppf "%d unknown connection(s)" unknown_connections in 378 | to_prefix prefix, "253", ([], of_prettier pp v) 379 | | RPL_LUSERME, v -> 380 | let pp ppf (clients, servers) = 381 | Fmt.pf ppf "I have %d clients and %d servers" clients servers in 382 | to_prefix prefix, "255", ([], of_prettier pp v) 383 | | RPL_MOTDSTART, msg -> 384 | to_prefix prefix, "375", ([], msg) 385 | | RPL_MOTD, v -> 386 | let pp ppf msg = Fmt.pf ppf "- %s" msg in 387 | to_prefix prefix, "372", ([], of_prettier pp v) 388 | | RPL_ENDOFMOTD, msg -> 389 | to_prefix prefix, "376", ([], msg) 390 | | RPL_TOPIC, (channel, topic) -> 391 | to_prefix prefix, "332", ([ Channel.to_string channel ], Some topic) 392 | | RPL_NOTOPIC, channel -> 393 | to_prefix prefix, "331", ([ Channel.to_string channel ], None) 394 | | RPL_NAMREPLY, { channel; kind; names; } -> 395 | let kind_to_string = function 396 | | `Secret -> "@" | `Private -> "*" | `Public -> "=" in 397 | let params = [ Channel.to_string channel; kind_to_string kind ] in 398 | let pp_name ppf = function 399 | | `None, nickname -> Nickname.pp ppf nickname 400 | | `Operator, nickname -> Fmt.pf ppf "@%a" Nickname.pp nickname 401 | | `Voice, nickname -> Fmt.pf ppf "+%a" Nickname.pp nickname in 402 | let msg = Fmt.str "%a" Fmt.(list ~sep:(const string " ") pp_name) names in 403 | to_prefix prefix, "353", (params, Some msg) 404 | | RPL_ENDOFNAMES, channel -> 405 | to_prefix prefix, "366", ([ Channel.to_string channel ], None) 406 | | RPL, { numeric; params; } -> 407 | to_prefix prefix, (Fmt.str "%03d" numeric), params 408 | | RPL_LUSERCHANNELS, v -> 409 | let pp ppf n = 410 | Fmt.pf ppf "%d channels formed" n in 411 | to_prefix prefix, "254", ([], of_prettier pp v) 412 | | ERR_NONICKNAMEGIVEN, () -> 413 | to_prefix prefix, "431", ([], Some "No nickname given") 414 | | ERR_NOTREGISTERED, () -> 415 | to_prefix prefix, "451", ([], Some "You are not registered") 416 | | ERR_NICKNAMEINUSE, nickname -> 417 | to_prefix prefix, "433", ([ Nickname.to_string nickname ], None) 418 | 419 | let pp_message ppf (Message (t, v)) = match t with 420 | | Pass -> Fmt.pf ppf "pass %s" v 421 | | Nick -> Fmt.pf ppf "nick %a" pp_nick v 422 | | User -> Fmt.pf ppf "user %a" pp_user v 423 | | Server -> Fmt.pf ppf "server %a" pp_server v 424 | | Oper -> Fmt.pf ppf "oper %a" pp_oper v 425 | | Quit -> Fmt.pf ppf "quit %S" v 426 | | SQuit -> Fmt.pf ppf "squit %a %S" Domain_name.pp (fst v) (snd v) 427 | | Join -> Fmt.pf ppf "join %a" Fmt.(Dump.list (Dump.pair Channel.pp (option (fmt "%S")))) v 428 | | Authenticate -> 429 | ( match v with 430 | | `Mechanism m -> Fmt.pf ppf "authenticate %a" pp_mechanism m 431 | | `Payload str -> Fmt.pf ppf "authenticate %s" str ) 432 | | _ -> 433 | try 434 | let _prefix, command, (ps, v) = to_line t v in 435 | ( match v with 436 | | Some v -> Fmt.pf ppf "%s %a :%s" command Fmt.(list ~sep:(any "@ ") string) ps v 437 | | None -> Fmt.pf ppf "%s %a" command Fmt.(list ~sep:(any "@ ") string) ps ) 438 | with _ -> Fmt.string ppf "" 439 | 440 | let apply_keys channels keys = 441 | let rec go acc channels keys = match channels with 442 | | [] -> List.rev acc 443 | | channel :: channels -> match keys with 444 | | key :: keys -> go ((channel, Some key) :: acc) channels keys 445 | | [] -> go ((channel, None) :: acc) channels [] in 446 | go [] channels keys 447 | 448 | let kind_of_string_exn = function 449 | | "=" -> `Public 450 | | "*" -> `Private 451 | | "@" -> `Secret 452 | | str -> Fmt.invalid_arg "Invalid type of channel: %S" str 453 | 454 | let rec name_of_string_exn str = 455 | if str = "" then Fmt.invalid_arg "Empty nickname" ; 456 | match str.[0] with 457 | | '@' -> `Operator, Nickname.of_string_exn (chop str) 458 | | '+' -> `Voice, Nickname.of_string_exn (chop str) 459 | | _ -> `None, Nickname.of_string_exn str 460 | and chop str = String.sub str 1 (String.length str - 1) 461 | 462 | let rec of_line 463 | : type a. a recv 464 | -> Decoder.t 465 | -> (a, [ `Invalid_parameters | `Invalid_command | `Invalid_reply ]) result 466 | = fun w ((prefix, command, vs) as line) -> 467 | let prefix : prefix option = match prefix with 468 | | None -> None 469 | | Some (`Server (`Ip6 v)) -> Some (Server (`Ip6 v)) 470 | | Some (`Server (`Host v)) -> Some (Server (`Host (Domain_name.of_string_exn v))) 471 | | Some (`User (name, user, Some (`Ip6 v))) -> 472 | let name = Nickname.of_string_exn name in 473 | Some (User { name; user; host= Some (`Ip6 v); }) 474 | | Some (`User (name, user, Some (`Host host))) -> 475 | let name = Nickname.of_string_exn name in 476 | let host = Domain_name.of_string_exn host in 477 | Some (User { name; user; host= Some (`Host host); }) 478 | | Some (`User (name, user, None)) -> 479 | let name = Nickname.of_string_exn name in 480 | Some (User { name; user; host= None; }) in 481 | match w, String.lowercase_ascii command, vs with 482 | | Recv Pass, "pass", ([ pass ], _) -> Ok (prefix, pass) 483 | | Recv Nick, "nick", ([ nick ], _) -> 484 | ( match Nickname.of_string nick with 485 | | Ok nick -> Ok (prefix, { nick; hopcount= None; }) 486 | | Error _ -> Error `Invalid_parameters ) 487 | | Recv Nick, "nick", ([], Some nick) -> 488 | ( try Ok (prefix, { nick= Nickname.of_string_exn nick; hopcount= None }) 489 | with _ -> Error `Invalid_parameters ) 490 | | Recv Nick, "nick", ([ nick; hopcount; ], _) -> 491 | ( try Ok (prefix, { nick= Nickname.of_string_exn nick; hopcount= Some (int_of_string hopcount) }) 492 | with _ -> Error `Invalid_parameters ) 493 | | Recv User, "user", ([ username; mode; _; ], realname) -> 494 | let realname = Option.value ~default:"" realname in 495 | ( try let mode = int_of_string mode in 496 | Ok (prefix, { username; mode; realname; }) 497 | with _ -> Error `Invalid_parameters ) 498 | | Recv Server, "server", ([ servername; hopcount; ], Some info) -> 499 | ( try let servername = Domain_name.of_string_exn servername in 500 | let hopcount = int_of_string hopcount in 501 | Ok (prefix, { servername; hopcount; info; }) 502 | with _ -> Error `Invalid_parameters ) 503 | | Recv Oper, "oper", ([ user; password; ], _) -> 504 | Ok (prefix, { user; password; }) 505 | | Recv Quit, "quit", ([], Some msg) -> Ok (prefix, msg) 506 | | Recv SQuit, "squit", ([ server ], Some msg) -> 507 | ( try let server = Domain_name.of_string_exn server in 508 | Ok (prefix, (server, msg)) 509 | with _ -> Error `Invalid_parameters ) 510 | | Recv Notice, "notice", (dsts, Some msg) -> 511 | ( try let dsts = String.concat "" dsts in 512 | let dsts = Destination.of_string_exn dsts in 513 | Ok (prefix, { dsts; msg; }) 514 | with _ -> Error `Invalid_parameters ) 515 | | Recv Join, "join", ([ channels; keys; ], _) -> 516 | let channels = Astring.String.cuts ~sep:"," channels in 517 | let keys = Astring.String.cuts ~sep:"," keys in 518 | ( try let channels = List.map Channel.of_string_exn channels in 519 | let channels = apply_keys channels keys in 520 | Ok (prefix, channels) 521 | with _ -> Error `Invalid_parameters ) 522 | | Recv Join, "join", ([ channels ], _) -> 523 | let channels = Astring.String.cuts ~sep:"," channels in 524 | ( try let channels = List.map Channel.of_string_exn channels in 525 | Ok (prefix, List.map (fun v -> v, None) channels) 526 | with _ -> Error `Invalid_parameters ) 527 | | Recv User_mode, "mode", ([ nickname ], Some modes) -> 528 | ( match Nickname.of_string nickname, User_mode.of_string modes with 529 | | Ok nickname, Ok modes -> Ok (prefix, { nickname; modes; }) 530 | | _ -> Error `Invalid_parameters ) 531 | | Recv User_mode, "mode", ([ nickname; modes; ], None) -> 532 | ( match Nickname.of_string nickname, User_mode.of_string modes with 533 | | Ok nickname, Ok modes -> Ok (prefix, { nickname; modes; }) 534 | | _ -> Error `Invalid_parameters ) 535 | | Recv Channel_mode, "mode", (channel :: parameters, _) -> 536 | ( try let channel = Channel.of_string_exn channel in 537 | let rec modes acc = function 538 | | [] -> List.rev acc 539 | | m :: (parameters :: tl1 as tl0) -> 540 | ( match Channel_mode.of_string ~ignore:false parameters with 541 | | Ok _ -> modes ((Channel_mode.of_string_exn m, None) :: acc) tl0 542 | | Error _ -> modes ((Channel_mode.of_string_exn m, Some parameters) :: acc) tl1 ) 543 | | [ m ] -> List.rev ((Channel_mode.of_string_exn m, None) :: acc) in 544 | Ok (prefix, { channel; modes= modes [] parameters }) 545 | with _ -> Error `Invalid_parameters ) 546 | | Recv Privmsg, "privmsg", ([ dsts ], msg) -> 547 | ( try let dsts = Destination.of_string_exn dsts in 548 | let msg = Option.value ~default:"" msg in 549 | Ok (prefix, (dsts, msg)) 550 | with _ -> Error `Invalid_parameters ) 551 | | Recv Ping, "ping", params -> 552 | ( match params with 553 | | [ src; dst ], None | [ src ], Some dst -> 554 | ( try let src = Domain_name.of_string_exn src in 555 | let dst = Domain_name.of_string_exn dst in 556 | Ok (prefix, (Some src, Some dst)) 557 | with _ -> Error `Invalid_parameters ) 558 | | [ src ], None -> 559 | ( try let src = Domain_name.of_string_exn src in 560 | Ok (prefix, (Some src, None)) 561 | with _ -> Error `Invalid_parameters ) 562 | | [], Some dst -> 563 | ( try let dst = Domain_name.of_string_exn dst in 564 | Ok (prefix, (None, Some dst)) 565 | with _ -> Error `Invalid_parameters ) 566 | | _ -> Error `Invalid_parameters ) 567 | | Recv Pong, "pong", params -> 568 | ( match params with 569 | | [ src; dst ], None | [ src ], Some dst -> 570 | ( try let src = Domain_name.of_string_exn src in 571 | let dst = Domain_name.of_string_exn dst in 572 | Ok (prefix, (Some src, Some dst)) 573 | with _ -> Error `Invalid_parameters ) 574 | | [ src ], None -> 575 | ( try let src = Domain_name.of_string_exn src in 576 | Ok (prefix, (Some src, None)) 577 | with _ -> Error `Invalid_parameters ) 578 | | [], Some dst -> 579 | ( try let dst = Domain_name.of_string_exn dst in 580 | Ok (prefix, (None, Some dst)) 581 | with _ -> Error `Invalid_parameters ) 582 | | _ -> Error `Invalid_parameters ) 583 | | Recv Part, "part", (channels, msg) -> 584 | ( try 585 | let channels = String.concat "" channels in 586 | let channels = Astring.String.cuts ~sep:"," channels in 587 | let channels = List.map Channel.of_string_exn channels in 588 | Ok (prefix, (channels, msg)) 589 | with _ -> Error `Invalid_parameters ) 590 | | Recv Topic, "topic", ([ channel ], topic) -> 591 | ( match Channel.of_string channel with 592 | | Ok channel -> Ok (prefix, (channel, topic)) 593 | | Error _ -> Error `Invalid_parameters ) 594 | | Recv Error, "error", (_, msg) -> Ok (prefix, msg) 595 | | Recv Authenticate, "authenticate", ([ "login" ], _) -> 596 | Ok (prefix, (`Mechanism LOGIN)) 597 | | Recv Authenticate, "authenticate", ([ "plain" ], _) -> 598 | Ok (prefix, (`Mechanism PLAIN)) 599 | | Recv Authenticate, "authenticate", ([ str ], _) -> 600 | Ok (prefix, (`Payload str)) 601 | | Recv RPL_WELCOME, "001", params -> Ok (prefix, to_prettier RPL_WELCOME params) 602 | | Recv RPL_YOURHOST, "002", params -> Ok (prefix, to_prettier RPL_YOURHOST params) 603 | | Recv RPL_CREATED, "003", params -> Ok (prefix, to_prettier RPL_CREATED params) 604 | | Recv RPL_MYINFO, "004", (_, msg) -> Ok (prefix, msg) 605 | | Recv RPL_BOUNCE, "005", (_, msg) -> Ok (prefix, msg) 606 | | Recv RPL_LUSERCLIENT, "251", params -> Ok (prefix, to_prettier RPL_LUSERCLIENT params) 607 | | Recv RPL_LUSEROP, "252", params -> Ok (prefix, to_prettier RPL_LUSEROP params) 608 | | Recv RPL_LUSERUNKNOWN, "253", params -> Ok (prefix, to_prettier RPL_LUSERUNKNOWN params) 609 | | Recv RPL_LUSERCHANNELS, "254", params -> Ok (prefix, to_prettier RPL_LUSERCHANNELS params) 610 | | Recv RPL_LUSERME, "255", params -> Ok (prefix, to_prettier RPL_LUSERME params) 611 | | Recv RPL_MOTDSTART, "375", (_, msg) -> Ok (prefix, msg) 612 | | Recv RPL_MOTD, "372", params -> Ok (prefix, to_prettier RPL_MOTD params) 613 | | Recv RPL_ENDOFMOTD, "376", (_, msg) -> Ok (prefix, msg) 614 | | Recv RPL_TOPIC, "332", ((_ :: _ as params), Some topic) -> 615 | let channel = List.hd (List.rev params) in 616 | ( try Ok (prefix, (Channel.of_string_exn channel, topic)) 617 | with _ -> Error `Invalid_parameters ) 618 | | Recv RPL_NOTOPIC, "331", ([ channel ], _) -> 619 | ( try Ok (prefix, Channel.of_string_exn channel) 620 | with _ -> Error `Invalid_parameters ) 621 | | Recv RPL_NAMREPLY, "353", ((_ :: _ as params), Some names) -> 622 | ( match List.rev params with 623 | | channel :: kind :: _ -> 624 | ( try let channel = Channel.of_string_exn channel in 625 | let kind = kind_of_string_exn kind in 626 | let names = List.map name_of_string_exn (Astring.String.cuts ~sep:" " names) in 627 | Ok (prefix, { channel; kind; names; }) 628 | with _ -> Error `Invalid_parameters ) 629 | | _ -> Error `Invalid_parameters ) 630 | | Recv RPL_ENDOFNAMES, "366", ((_ :: _ as params), _) -> 631 | ( try let channel = Channel.of_string_exn (List.hd (List.rev params) ) in 632 | Ok (prefix, channel) 633 | with _ -> Error `Invalid_parameters ) 634 | | Recv RPL, numeric, params -> 635 | ( try 636 | Log.debug (fun m -> m "Got an unknown code %S %a:@ %a" numeric Fmt.(Dump.list string) (fst params) Fmt.(Dump.option string) (snd params)); 637 | Ok (prefix, { numeric= int_of_string numeric; params; }) 638 | with _ -> Error `Invalid_reply ) 639 | | Recv ERR_NONICKNAMEGIVEN, "431", _ -> Ok (prefix, ()) 640 | | Recv ERR_NICKNAMEINUSE, "433", ([ _; nickname ], _) -> 641 | Ok (prefix, Nickname.of_string_exn nickname) (* TODO(dinosaure): exception leak. *) 642 | | Recv ERR_NOTREGISTERED, "451", _ -> Ok (prefix, ()) 643 | | Any, _, _ -> 644 | ( match command_of_line line with 645 | | Error _ -> Error `Invalid_command 646 | | Ok (Command c) -> match of_line (Recv c) line with 647 | | Ok (prefix, v) -> Ok (prefix, Message (c, v)) 648 | | Error _ as err -> err ) 649 | | Many, _, _ -> failwith "Impossible to get many lines from [of_line]" 650 | (* XXX(dinosaure): should never occur! *) 651 | | _ -> Error `Invalid_command 652 | 653 | let prefix ?user ?host name : prefix = 654 | User { name; user; host= Option.map (fun v -> `Host v) host; } 655 | 656 | let send : type a. a t -> a -> send 657 | = fun w v -> Send (w, v) 658 | let recv : type a. a t -> (prefix option * a) recv 659 | = fun w -> Recv w 660 | let any = Any 661 | let many = Many 662 | 663 | let encode 664 | : ?prefix:prefix -> Encoder.encoder -> send -> [> Encoder.error ] Encoder.state 665 | = fun ?prefix encoder (Send (w, v)) -> 666 | let line = to_line ?prefix w v in 667 | Encoder.encode_line (fun () -> Encoder.Done) encoder line 668 | 669 | type error = [ `Invalid_command | `Invalid_parameters | `Invalid_reply | Decoder.error ] 670 | 671 | let pp_error ppf = function 672 | | `Invalid_command -> Fmt.string ppf "Invalid command" 673 | | `Invalid_parameters -> Fmt.string ppf "Invalid parameters" 674 | | `Invalid_reply -> Fmt.string ppf "Invalid reply" 675 | | #Decoder.error as err -> Decoder.pp_error ppf err 676 | 677 | let pp_host' ppf = function 678 | | `Host str -> Fmt.string ppf str 679 | | `Ip6 v -> Ipaddr.V6.pp ppf v 680 | 681 | let pp_line ppf = function 682 | | Some (`Server host), cmd, (msg, v) -> Fmt.pf ppf "%a %s %a %a" pp_host' host cmd Fmt.(Dump.list string) msg Fmt.(Dump.option string) v 683 | | Some (`User (user, v, host)), cmd, (msg, v') -> Fmt.pf ppf "%s %a %a %s %a %a" user Fmt.(Dump.option string) v Fmt.(option pp_host') host cmd Fmt.(Dump.list string) msg Fmt.(Dump.option string) v' 684 | | None, cmd, (msg, v) -> Fmt.pf ppf "%s %a %a" cmd Fmt.(Dump.list string) msg Fmt.(Dump.option string) v 685 | 686 | let decode 687 | : type a. Decoder.decoder -> a recv -> (a, [> error ]) Decoder.state 688 | = fun decoder -> function 689 | | Many -> 690 | let rec k acc line decoder = match of_line Any line with 691 | | Ok x -> 692 | Decoder.junk_eol decoder ; 693 | if Decoder.at_least_one_line decoder 694 | then Decoder.peek_line ~k:(k (x :: acc)) decoder 695 | |> Decoder.reword_error (fun err -> (err :> error)) 696 | else Decoder.return decoder (List.rev (x :: acc)) 697 | | Error err -> 698 | Log.err (fun m -> m "Got an error while decoding %a: %a" pp_line line pp_error err); 699 | Decoder.leave_with decoder (err :> error) 700 | | exception exn -> 701 | Log.err (fun m -> m "Got an exception while decoding %a: %S" pp_line line (Printexc.to_string exn)); 702 | Decoder.leave_with decoder `Invalid_command in 703 | Decoder.peek_line ~k:(k []) decoder 704 | |> Decoder.reword_error (fun err -> (err :> error)) 705 | | w -> 706 | let k line decoder = match of_line w line with 707 | | Ok v -> Decoder.junk_eol decoder ; Decoder.return decoder v 708 | | Error err -> 709 | Log.err (fun m -> m "Got an error while decoding %a: %a" pp_line line pp_error err); 710 | Decoder.leave_with decoder (err :> error) 711 | | exception exn -> 712 | Log.err (fun m -> m "Got an exception while decoding %a: %S" pp_line line (Printexc.to_string exn)); 713 | Decoder.leave_with decoder `Invalid_command in 714 | Decoder.peek_line ~k decoder 715 | |> Decoder.reword_error (fun err -> (err :> error)) 716 | --------------------------------------------------------------------------------