├── .gitignore ├── .travis.yml ├── CHANGES.md ├── LICENSE.md ├── README.md ├── dune-project ├── otr.opam ├── src ├── dune ├── otr.ml ├── otr.mli ├── otr_ake.ml ├── otr_ake.mli ├── otr_builder.ml ├── otr_builder.mli ├── otr_crypto.ml ├── otr_crypto.mli ├── otr_packet.ml ├── otr_packet.mli ├── otr_parser.ml ├── otr_parser.mli ├── otr_ratchet.ml ├── otr_ratchet.mli ├── otr_smp.ml ├── otr_smp.mli ├── otr_state.ml └── otr_state.mli └── tests ├── dune └── feedback.ml /.gitignore: -------------------------------------------------------------------------------- 1 | _build/ 2 | *.byte 3 | *.native 4 | *.install 5 | .merlin 6 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-opam.sh 3 | script: bash -ex .travis-opam.sh 4 | sudo: required 5 | env: 6 | global: 7 | - PACKAGE="otr" 8 | matrix: 9 | - OCAML_VERSION=4.07 10 | - OCAML_VERSION=4.08 11 | - OCAML_VERSION=4.09 12 | - OCAML_VERSION=4.10 13 | notifications: 14 | email: false 15 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | ## v1.0.0 (2024-10-21) 2 | 3 | * Use string instead of cstruct (#16 @hannesm) 4 | 5 | ## v0.3.10 (2021-10-25) 6 | 7 | * remove rresult dependency 8 | * use sexplib0 instead of sexplib for mirage-crypto 0.10.4+ compatibility 9 | (the dependency stated sexplib0 since some time, but sexplib was inherited 10 | via mirage-crypto-pk) 11 | 12 | ## v0.3.9 (2021-08-04) 13 | 14 | * use Cstruct.length instead of deprecated Cstruct.len (requires cstruct 6.0.0) 15 | 16 | ## v0.3.8 (2020-03-15) 17 | 18 | * fix crypt function (0.3.7 used the counter wrong, the 0 should be the other half) 19 | 20 | ## v0.3.7 (2020-03-11) 21 | 22 | * use mirage-crypto instead of nocrypto 23 | 24 | ## 0.3.6 (2019-02-16) 25 | 26 | * move build system to dune 27 | 28 | ## 0.3.5 (2018-08-25) 29 | 30 | * remove usage of ppx 31 | 32 | ## 0.3.4 (2017-11-23) 33 | 34 | * prefix modules with "Otr_" 35 | * drop OCaml < 4.03.0 support 36 | 37 | ## 0.3.3 (2016-07-17) 38 | 39 | * improve interop (instance tags) #10 40 | * don't pack anymore 41 | * switch to topkg 42 | 43 | ## 0.3.2 (2016-05-09) 44 | 45 | * use result, 4.03 compatibility 46 | 47 | ## 0.3.1 (2016-03-21) 48 | 49 | * get rid of camlp4, use ppx instead 50 | 51 | ## 0.3.0 (2015-12-20) 52 | 53 | * add `update_config` function to update a session with given parameters 54 | * use Astring instead of Stringext for String functionality 55 | 56 | ## 0.2.0 (2015-07-02) 57 | 58 | * config contains policies and versions, but no longer the DSA key 59 | * DSA key needs to be provided separately in new_session 60 | * own_fingerprint takes a DSA key, not a config 61 | 62 | ## 0.1.1 (2015-04-25) 63 | 64 | * expose full config structure 65 | * handle simultaneous open (both parties send a DH_COMMIT) gracefully 66 | 67 | ## 0.1.0 (2015-01-24) 68 | 69 | * initial release 70 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014, Hannes Mehnert 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | * Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | 10 | * Redistributions in binary form must reproduce the above copyright notice, 11 | this list of conditions and the following disclaimer in the documentation 12 | and/or other materials provided with the distribution. 13 | 14 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 15 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 16 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 17 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 18 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 19 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 20 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 21 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 22 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 23 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 24 | 25 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## OTR - Off the record implementation purely in OCaml 2 | 3 | %%VERSION%% 4 | 5 | This is an implementation of version 2 and 3 of the Off-the-record 6 | protocol (https://otr.cypherpunks.ca/Protocol-v3-4.0.0.html) in OCaml. 7 | 8 | Including the socialist millionairs protocol to authenticate a 9 | communication partner over an encrypted channel providing a shared 10 | secret. 11 | 12 | ## Documentation 13 | 14 | [![Build Status](https://travis-ci.org/hannesm/ocaml-otr.svg?branch=master)](https://travis-ci.org/hannesm/ocaml-otr) 15 | 16 | [API documentation](https://hannesm.github.io/ocaml-otr/doc/) is available online 17 | 18 | Best to be used with [jackline](http://github.com/hannesm/jackline). 19 | 20 | ## Installation 21 | 22 | `opam install otr` will install this library, once you have installed OCaml (>= 23 | 4.02.0) and opam (>= 1.2.2). -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.0) 2 | (name otr) 3 | -------------------------------------------------------------------------------- /otr.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Hannes Mehnert " 3 | authors: "Hannes Mehnert " 4 | license: "BSD-2-Clause" 5 | homepage: "https://github.com/hannesm/ocaml-otr" 6 | doc: "https://hannesm.github.io/ocaml-otr/doc" 7 | bug-reports: "https://github.com/hannesm/ocaml-otr/issues" 8 | depends: [ 9 | "ocaml" {>= "4.13.0"} 10 | "dune" {>= "1.0.0"} 11 | "sexplib0" 12 | "mirage-crypto" {>= "1.0.0"} 13 | "mirage-crypto-pk" {>= "1.0.0"} 14 | "mirage-crypto-rng" {>= "1.0.0"} 15 | "digestif" {>= "1.2.0"} 16 | "astring" 17 | "base64" {>= "3.1.0"} 18 | ] 19 | conflicts: [ "result" {< "1.5"} ] 20 | build: [ 21 | ["dune" "subst"] {dev} 22 | ["dune" "build" "-p" name "-j" jobs] 23 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 24 | ] 25 | dev-repo: "git+https://github.com/hannesm/ocaml-otr.git" 26 | synopsis: "Off the record implementation purely in OCaml" 27 | description: """ 28 | This is an implementation of version 2 and 3 of the Off-the-record 29 | protocol (https://otr.cypherpunks.ca/Protocol-v3-4.0.0.html) in OCaml. 30 | 31 | Including the socialist millionairs protocol to authenticate a 32 | communication partner over an encrypted channel providing a shared 33 | secret. 34 | """ 35 | x-maintenance-intent: [ "(latest)" ] 36 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name otr) 3 | (public_name otr) 4 | (libraries digestif mirage-crypto mirage-crypto-pk mirage-crypto-rng sexplib0 astring base64)) 5 | -------------------------------------------------------------------------------- /src/otr.ml: -------------------------------------------------------------------------------- 1 | module State = Otr_state 2 | 3 | module Engine = struct 4 | open Otr_state 5 | 6 | let policy ctx p = List.mem p ctx.config.policies 7 | 8 | let handle_cleartext ctx = 9 | match ctx.state.message_state with 10 | | MSGSTATE_PLAINTEXT when policy ctx `REQUIRE_ENCRYPTION -> [`Warning "received unencrypted data"] 11 | | MSGSTATE_PLAINTEXT -> [] 12 | | MSGSTATE_ENCRYPTED _ | MSGSTATE_FINISHED -> [`Warning "received unencrypted data"] 13 | 14 | let commit ctx their_versions = 15 | match Otr_ake.dh_commit ctx their_versions with 16 | | Ok (ctx, out) -> Ok (ctx, Some out) 17 | | Error (Otr_ake.Unknown e) -> Error e 18 | | Error Otr_ake.VersionMismatch -> Error "couldn't agree on a version" 19 | | Error Otr_ake.InstanceMismatch -> Error "wrong instances" 20 | | Error (Otr_ake.Unexpected _) -> Error "unexpected message" 21 | 22 | let handle_whitespace_tag ctx their_versions = 23 | let warn = handle_cleartext ctx in 24 | let* ctx, out = 25 | if policy ctx `WHITESPACE_START_AKE then 26 | commit ctx their_versions 27 | else 28 | Ok (ctx, None) 29 | in 30 | Ok (ctx, out, warn) 31 | 32 | let handle_error ctx = 33 | if policy ctx `ERROR_START_AKE then 34 | Some (Otr_builder.query_message ctx.config.versions) 35 | else 36 | None 37 | 38 | let handle_tlv state typ buf = 39 | let open Otr_packet in 40 | match typ with 41 | | Some PADDING -> (state, None, []) 42 | | Some DISCONNECTED -> ({ state with message_state = MSGSTATE_FINISHED }, 43 | None, 44 | [`Warning "OTR connection lost"]) 45 | | Some EXTRA_SYMMETRIC_KEY -> (state, None, [`Warning "not handling extra symmetric key"]) 46 | | Some (SMP_MESSAGE_1 | SMP_MESSAGE_2 | SMP_MESSAGE_3 | SMP_MESSAGE_4 | SMP_ABORT | SMP_MESSAGE_1Q as smp_type) -> 47 | begin match Otr_smp.handle_smp state.smp_state smp_type buf with 48 | | Ok (smp_state, out, usr) -> ({ state with smp_state }, out, usr) 49 | | Error e -> 50 | let msg = Otr_smp.error_to_string e in 51 | ({ state with smp_state = SMPSTATE_EXPECT1 }, None, [`Warning msg]) 52 | end 53 | | None -> (state, None, [`Warning "unknown tlv type"]) 54 | 55 | let rec filter_map ?(f = fun x -> x) = function 56 | | [] -> [] 57 | | x::xs -> 58 | match f x with 59 | | None -> filter_map ~f xs 60 | | Some x' -> x' :: filter_map ~f xs 61 | 62 | let handle_tlvs state = function 63 | | None -> Ok (state, None, []) 64 | | Some data -> 65 | let rec process_data state data out warn = 66 | match String.length data with 67 | | 0 -> (state, out, warn) 68 | | _ -> match Otr_parser.parse_tlv data with 69 | | Ok (typ, buf, rest) -> 70 | let state, out', warn' = handle_tlv state typ buf in 71 | process_data state rest (out' :: out) (warn @ warn') 72 | | Error _ -> (state, out, [`Warning "ignoring malformed TLV"]) 73 | in 74 | let state, out, warn = process_data state data [] [] in 75 | let out = match filter_map out with 76 | | [] -> None 77 | | xs -> Some (String.concat "" xs) 78 | in 79 | Ok (state, out, warn) 80 | 81 | let decrypt dh_keys symm version instances bytes = 82 | match Otr_parser.parse_data bytes with 83 | | Ok (version', instances', _flags, s_keyid, r_keyid, dh_y, ctr', encdata, mac, reveal) -> 84 | if version <> version' then 85 | Ok (dh_keys, symm, None, [`Warning "ignoring message with invalid version"]) 86 | else if 87 | match version, instances, instances' with 88 | | `V3, Some (mya, myb), Some (youra, yourb) when (mya = youra) && (myb = yourb) -> false 89 | | `V2, _, _ -> false 90 | | _ -> true 91 | then 92 | Ok (dh_keys, symm, None, [`Warning "ignoring message with invalid instances"]) 93 | else 94 | begin match Otr_ratchet.check_keys dh_keys s_keyid r_keyid dh_y with 95 | | Some x -> Ok (dh_keys, symm, None, [`Warning x]) 96 | | None -> 97 | let symm, keyblock = Otr_ratchet.keys dh_keys symm s_keyid r_keyid in 98 | if ctr' <= keyblock.recv_ctr then 99 | Ok (dh_keys, symm, None, [`Warning "ignoring message with invalid counter"]) 100 | else 101 | let stop = String.length bytes - String.length reveal - 4 - 20 in 102 | let* () = guard (stop >= 0) "invalid data" in 103 | let mac' = Otr_crypto.sha1mac ~key:keyblock.recv_mac (String.sub bytes 0 stop) in 104 | let* () = guard (String.equal mac mac') "invalid mac" in 105 | let dec = Otr_crypto.crypt ~key:keyblock.recv_aes ~ctr:ctr' encdata in 106 | let txt, data = 107 | let len = String.length dec in 108 | let stop = 109 | try String.index dec '\000' 110 | with Not_found -> len 111 | in 112 | let txt = String.sub dec 0 stop in 113 | if stop = len || succ stop = len then 114 | (txt, "") 115 | else 116 | let stop' = succ stop in 117 | (txt, String.sub dec stop' (len - stop')) 118 | in 119 | let data = if data = "" then None else Some data in 120 | let ret = (if txt = "" then [] else [`Received_encrypted txt]) in 121 | let dh_keys = Otr_ratchet.rotate_keys dh_keys s_keyid r_keyid dh_y 122 | and symm = Otr_ratchet.set_recv_counter ctr' s_keyid r_keyid symm 123 | in 124 | Ok (dh_keys, symm, data, ret) 125 | end 126 | | Error Otr_parser.Underflow -> Error "Malformed OTR data message: parser reported underflow" 127 | | Error Otr_parser.LeadingZero -> Error "Malformed OTR data message: parser reported leading zero" 128 | | Error (Otr_parser.Unknown x) -> Error ("Malformed OTR data message: " ^ x) 129 | 130 | let encrypt dh_keys symm reveal_macs version instances flags data = 131 | let symm, reveal = Otr_ratchet.reveal dh_keys symm in 132 | let our_id = Int32.pred dh_keys.our_keyid in 133 | let symm, keyblock = Otr_ratchet.keys dh_keys symm dh_keys.their_keyid our_id in 134 | let our_ctr = Int64.succ keyblock.send_ctr in 135 | let enc = Otr_crypto.crypt ~key:keyblock.send_aes ~ctr:our_ctr data in 136 | let data = Otr_builder.data version instances flags our_id dh_keys.their_keyid (snd dh_keys.dh) our_ctr enc in 137 | let mac = Otr_crypto.sha1mac ~key:keyblock.send_mac data in 138 | let reveal = 139 | let macs = if reveal_macs then 140 | String.concat "" (List.map (fun x -> x.recv_mac) reveal) 141 | else 142 | "" 143 | in 144 | Otr_builder.encode_data macs 145 | in 146 | let out = String.concat "" [ data ; mac ; reveal] in 147 | let symm = Otr_ratchet.inc_send_counter dh_keys.their_keyid our_id symm in 148 | (symm, out) 149 | 150 | let wrap_b64string = function 151 | | None -> None 152 | | Some m -> 153 | let encoded = Base64.encode_string m in 154 | Some (otr_mark ^ encoded ^ ".") 155 | 156 | let handle_data ctx bytes = 157 | match ctx.state.message_state with 158 | | MSGSTATE_PLAINTEXT -> 159 | begin match Otr_ake.handle_auth ctx bytes with 160 | | Ok (ctx, out, warn) -> Ok (ctx, wrap_b64string out, warn) 161 | | Error (Otr_ake.Unexpected ignore) -> 162 | if ignore then 163 | Ok (ctx, None, []) 164 | else 165 | let warn = "received encrypted data while in plaintext mode, ignoring unreadable message" in 166 | Ok (ctx, 167 | Some (otr_err_mark ^ " ignoring unreadable message"), 168 | [`Warning warn]) 169 | | Error (Otr_ake.Unknown x) -> Error ("AKE error encountered: " ^ x) 170 | | Error Otr_ake.VersionMismatch -> 171 | Ok (ctx, None, [`Warning "wrong version in message"]) 172 | | Error Otr_ake.InstanceMismatch -> 173 | Ok (ctx, None, [`Warning "wrong instances in message"]) 174 | end 175 | | MSGSTATE_ENCRYPTED enc_data -> 176 | let* dh_keys, symms, data, ret = decrypt enc_data.dh_keys enc_data.symms ctx.version ctx.instances bytes in 177 | let state = { ctx.state with message_state = MSGSTATE_ENCRYPTED { enc_data with dh_keys ; symms } } in 178 | let* state, out, warn = handle_tlvs state data in 179 | let state, out = match out with 180 | | None -> (state, None) 181 | | Some x -> 182 | match state.message_state with 183 | | MSGSTATE_ENCRYPTED enc_data -> 184 | let symms, out = encrypt enc_data.dh_keys enc_data.symms (reveal_macs ctx) ctx.version ctx.instances false ("\000" ^ x) in 185 | ({ state with message_state = MSGSTATE_ENCRYPTED { enc_data with symms } }, 186 | wrap_b64string (Some out)) 187 | | _ -> (state, out) 188 | in 189 | let ctx = { ctx with state } in 190 | Ok (ctx, out, ret @ warn) 191 | | MSGSTATE_FINISHED -> 192 | Ok (ctx, None, [`Warning "received data while in finished state, ignoring"]) 193 | 194 | (* operations triggered by a user *) 195 | let start_otr ctx = 196 | (reset_session ctx, Otr_builder.query_message ctx.config.versions) 197 | 198 | let send_otr ctx data = 199 | match ctx.state.message_state with 200 | | MSGSTATE_PLAINTEXT when policy ctx `REQUIRE_ENCRYPTION -> 201 | (ctx, 202 | Some (Otr_builder.query_message ctx.config.versions), 203 | `Warning ("didn't send message, there was no encrypted connection: " ^ data)) 204 | | MSGSTATE_PLAINTEXT when policy ctx `SEND_WHITESPACE_TAG -> 205 | (* XXX: and you have not received a plaintext message from this correspondent since last entering MSGSTATE_PLAINTEXT *) 206 | (ctx, Some (data ^ (Otr_builder.tag ctx.config.versions)), `Sent data) 207 | | MSGSTATE_PLAINTEXT -> (ctx, Some data, `Sent data) 208 | | MSGSTATE_ENCRYPTED enc_data -> 209 | let symms, out = encrypt enc_data.dh_keys enc_data.symms (reveal_macs ctx) ctx.version ctx.instances false data in 210 | let state = { ctx.state with message_state = MSGSTATE_ENCRYPTED { enc_data with symms } } in 211 | let out = wrap_b64string (Some out) in 212 | ({ ctx with state }, out, `Sent_encrypted data) 213 | | MSGSTATE_FINISHED -> 214 | (ctx, None, `Warning ("didn't send message, OTR session is finished: " ^ data)) 215 | 216 | let end_otr ctx = 217 | match ctx.state.message_state with 218 | | MSGSTATE_PLAINTEXT -> (ctx, None) 219 | | MSGSTATE_ENCRYPTED enc_data -> 220 | let data = Otr_builder.tlv Otr_packet.DISCONNECTED in 221 | let _, out = encrypt enc_data.dh_keys enc_data.symms (reveal_macs ctx) ctx.version ctx.instances true ("\000" ^ data) in 222 | (reset_session ctx, wrap_b64string (Some out)) 223 | | MSGSTATE_FINISHED -> 224 | (reset_session ctx, None) 225 | 226 | let handle_fragment ctx (k, n) frag = 227 | match k, n, fst ctx.fragments with 228 | | 1, _, _ -> ({ ctx with fragments = ((k, n), frag) }, None) 229 | | k, n, (stored_k, stored_n) when n = stored_n && k = succ stored_k && n = k -> 230 | (* last fragment *) 231 | let full = (snd ctx.fragments) ^ frag in 232 | (rst_frag ctx, Some full) 233 | | k, n, (stored_k, stored_n) when n = stored_n && k = succ stored_k -> 234 | ({ ctx with fragments = ((k, n), (snd ctx.fragments) ^ frag) }, None) 235 | | _ -> (rst_frag ctx, None) 236 | 237 | let handle_fragment_v3 ctx instances kn frag = 238 | match ctx.instances, instances with 239 | | Some (a, b), (a', b') when (a = a' && b = b') || b' = 0l -> 240 | handle_fragment ctx kn frag 241 | | _ -> (ctx, None) 242 | 243 | let recv text = match text with None -> [] | Some x -> [ `Received x ] 244 | 245 | let handle_input ctx = function 246 | | `PlainTag (versions, text) -> 247 | begin match handle_whitespace_tag ctx versions with 248 | | Ok (ctx, out, warn) -> 249 | (ctx, wrap_b64string out, warn @ recv text) 250 | | Error e -> 251 | (reset_session ctx, 252 | Some (otr_err_mark ^ e), 253 | [`Warning e] @ recv text) 254 | end 255 | | `Query versions -> 256 | begin match commit ctx versions with 257 | | Ok (ctx, out) -> (ctx, wrap_b64string out, []) 258 | | Error e -> (reset_session ctx, Some (otr_err_mark ^ e), [`Warning e] ) 259 | end 260 | | `Error message -> 261 | let out = handle_error ctx in 262 | (reset_session ctx, out, 263 | [`Received_error ("Received OTR Error: " ^ message)]) 264 | | `Data bytes -> 265 | begin match handle_data ctx bytes with 266 | | Ok (ctx, out, warn) -> (ctx, out, warn) 267 | | Error e -> (reset_session ctx, Some (otr_err_mark ^ e), [ `Warning e]) 268 | end 269 | | `String message -> 270 | let user = handle_cleartext ctx in 271 | (ctx, None, user @ recv (Some message)) 272 | | `ParseError err -> 273 | (reset_session ctx, 274 | Some (otr_err_mark ^ err), 275 | [`Warning (err ^ " while parsing OTR message")]) 276 | | `Fragment_v2 _ | `Fragment_v3 _ -> 277 | (reset_session ctx, 278 | Some (otr_err_mark ^ "unexpected recursive fragment"), 279 | [`Warning "ignoring unexpected recursive fragment"]) 280 | 281 | let handle_fragments ctx = function 282 | | `Fragment_v2 (kn, piece) -> 283 | if ctx.version = `V2 then 284 | Ok (handle_fragment ctx kn piece) 285 | else 286 | Error "wrong version in V2 fragment" 287 | | `Fragment_v3 (instances, kn, piece) -> 288 | if ctx.version = `V3 then 289 | Ok (handle_fragment_v3 ctx instances kn piece) 290 | else 291 | Error "wrong version in V3 fragment" 292 | 293 | (* session -> string -> (session * to_send * ret) *) 294 | let handle ctx bytes = 295 | match Otr_parser.classify_input bytes with 296 | | `Fragment_v2 _ | `Fragment_v3 _ as f -> 297 | begin match handle_fragments ctx f with 298 | | Ok (ctx, None) -> (ctx, None, []) 299 | | Ok (ctx, Some x) -> handle_input ctx (Otr_parser.classify_input x) 300 | | Error txt -> (ctx, Some (otr_err_mark ^ txt), [`Warning txt]) 301 | end 302 | | x -> handle_input (rst_frag ctx) x 303 | 304 | let handle_smp ctx call = 305 | let enc enc_data out smp_state = 306 | let data = "\000" ^ out in 307 | let symms, out = encrypt enc_data.dh_keys enc_data.symms (reveal_macs ctx) ctx.version ctx.instances false data in 308 | let message_state = MSGSTATE_ENCRYPTED { enc_data with symms } in 309 | let state = { ctx.state with message_state ; smp_state } in 310 | ({ ctx with state }, wrap_b64string (Some out)) 311 | in 312 | match ctx.state.message_state with 313 | | MSGSTATE_ENCRYPTED enc_data -> ( match call enc_data ctx.state.smp_state with 314 | | Ok (smp_state, Some out) -> 315 | let st, out = enc enc_data out smp_state in 316 | (st, out, []) 317 | | Ok (smp_state, None) -> 318 | let state = { ctx.state with smp_state } in 319 | ({ ctx with state }, None, []) 320 | | Error e -> 321 | let out = Otr_builder.tlv Otr_packet.SMP_ABORT in 322 | let st, out = enc enc_data out SMPSTATE_EXPECT1 in 323 | let err = Otr_smp.error_to_string e in 324 | (st, out, [`Warning err]) ) 325 | | _ -> (ctx, None, [`Warning "need an encrypted session for SMP"]) 326 | 327 | let start_smp ctx ?question secret = 328 | handle_smp ctx (fun enc smp -> Otr_smp.start_smp ctx.dsa enc smp ?question secret) 329 | 330 | let abort_smp ctx = 331 | handle_smp ctx (fun _ smp -> Otr_smp.abort_smp smp) 332 | 333 | let answer_smp ctx secret = 334 | handle_smp ctx (fun enc smp -> Otr_smp.handle_secret ctx.dsa enc smp secret) 335 | end 336 | 337 | module Utils = struct 338 | open State 339 | 340 | let fingerprint x = 341 | Otr_crypto.OtrDsa.fingerprint x 342 | 343 | let their_fingerprint ctx = 344 | match ctx.state.message_state with 345 | | MSGSTATE_ENCRYPTED enc -> Some (fingerprint enc.their_dsa) 346 | | _ -> None 347 | 348 | let own_fingerprint dsa = 349 | fingerprint (Mirage_crypto_pk.Dsa.pub_of_priv dsa) 350 | end 351 | 352 | -------------------------------------------------------------------------------- /src/otr.mli: -------------------------------------------------------------------------------- 1 | (** Off-the-Record, in pure OCaml 2 | 3 | Off-the-Record (OTR) ({{:https://otr.cypherpunks.ca/otr-wpes.pdf} 4 | developed by Goldberg et al.}) is a cryptographic protocol used in 5 | instant messaging. It provides both authentication (using 6 | long-term 1024 bit DSA keys), and encryption (using AES 128 in 7 | counter mode). An authenticated Diffie-Hellman key exchange (with 8 | 1536 bit {{:https://tools.ietf.org/html/rfc3526#section-2}Oakley5} 9 | group) establishes the shared secrets (providing forward secrecy). 10 | 11 | The 12 | {{:https://en.wikipedia.org/wiki/Socialist_millionaire}socialist 13 | millionaire problem} (SMP) allows in-band verification of the 14 | long-term DSA keys using a shared secret and zero knowledge 15 | proofs. 16 | 17 | This implementation covers both protocol 18 | {{:https://otr.cypherpunks.ca/Protocol-v2-3.1.0.html}version 2} 19 | and {{:https://otr.cypherpunks.ca/Protocol-v3-4.0.0.html}version 20 | 3}, and implements the socialist millionairs problem. {!State} 21 | defines configuration and types, {!Engine} processing of incoming 22 | and outgoing messages as well as initiation and teardown of 23 | sessions and socialist millionairs problem, and {!Utils} provides 24 | basic fingerprint utilities as defined in the OTR 25 | specification. 26 | 27 | {e %%VERSION%% - {{:%%PKG_HOMEPAGE%% }homepage}} 28 | *) 29 | 30 | (** States and types *) 31 | module State : sig 32 | 33 | (** {2 Type definitions and predicates} *) 34 | 35 | (** Return values of functions in the {!Engine} module. *) 36 | type ret = [ 37 | | `Warning of string 38 | | `Received_error of string 39 | | `Received of string 40 | | `Established_encrypted_session of string 41 | | `Received_encrypted of string 42 | | `SMP_awaiting_secret 43 | | `SMP_received_question of string 44 | | `SMP_success 45 | | `SMP_failure 46 | ] 47 | 48 | (** OTR policies, as defined in the protocol. *) 49 | type policy = [ 50 | | `REQUIRE_ENCRYPTION 51 | | `SEND_WHITESPACE_TAG 52 | | `WHITESPACE_START_AKE 53 | | `ERROR_START_AKE 54 | | `REVEAL_MACS 55 | ] 56 | 57 | val sexp_of_policy : policy -> Sexplib0.Sexp.t 58 | val policy_of_sexp : Sexplib0.Sexp.t -> policy 59 | 60 | (** [policy_to_string policy] is [string], the string representation 61 | of the given [policy]. *) 62 | val policy_to_string : policy -> string 63 | 64 | (** [string_to_policy string] is [policy], the [policy] matching the 65 | string ([None] if none matches). *) 66 | val string_to_policy : string -> policy option 67 | 68 | (** [all_policies] returns a list of all defined policies. *) 69 | val all_policies : policy list 70 | 71 | (** OTR protocol versions supported by this library *) 72 | type version = [ `V2 | `V3 ] 73 | 74 | val sexp_of_version : version -> Sexplib0.Sexp.t 75 | val version_of_sexp : Sexplib0.Sexp.t -> version 76 | 77 | (** [version_to_string version] is [string], the string 78 | representation of the [version]. *) 79 | val version_to_string : version -> string 80 | 81 | (** [string_to_version string] is [version], the [version] matching 82 | the string ([None] if none matches). *) 83 | val string_to_version : string -> version option 84 | 85 | (** [all_versions] returns a list of all supported versions. *) 86 | val all_versions : version list 87 | 88 | (** OTR configuration consisting of a set of policies and versions. *) 89 | type config = { 90 | policies : policy list ; 91 | versions : version list ; 92 | } 93 | 94 | val sexp_of_config : config -> Sexplib0.Sexp.t 95 | val config_of_sexp : Sexplib0.Sexp.t -> config 96 | 97 | (** [config versions policies] is [config], the configuration with 98 | the given [versions] and [policies]. *) 99 | val config : version list -> policy list -> config 100 | 101 | (** An abstract OTR session *) 102 | type session 103 | 104 | (** [session_to_string session] is [string], the string 105 | representation of the [session]. *) 106 | val session_to_string : session -> string 107 | 108 | (** [version session] is [version], the current active protocol 109 | version of this [session]. *) 110 | val version : session -> version 111 | 112 | (** [is_encrypted session] is [true] if the session is 113 | established. *) 114 | val is_encrypted : session -> bool 115 | 116 | (** [their_dsa session] is [dsa], the public DSA key used by the 117 | communication partner (if the session is established). *) 118 | val their_dsa : session -> Mirage_crypto_pk.Dsa.pub option 119 | 120 | (** [new_session configuration dsa ()] is [session], a fresh session given 121 | the [configuration] and [dsa] private key. *) 122 | val new_session : config -> Mirage_crypto_pk.Dsa.priv -> unit -> session 123 | 124 | (** [update_config config session] is [session], the [session] 125 | adjusted to the [config]. Note: the [session] might not conform 126 | to the config anymore! *) 127 | val update_config : config -> session -> session 128 | end 129 | 130 | (** Message processing *) 131 | module Engine : sig 132 | 133 | (** {2 Message processing} *) 134 | 135 | (** Either when an OTR session should be established, or if a 136 | message containing OTR data is received, the corresponding 137 | function should be called to decrypt or encrypt the OTR data, or 138 | initiate a handshake. *) 139 | 140 | (** [start_otr session] is [session', out], which initiates an OTR 141 | session. [out] should be sent to the communication partner, 142 | [session'] used in further API calls. The [session] is reset, 143 | and [out] contains an OTR query message (content depends on the 144 | configured {!State.version}). *) 145 | val start_otr : State.session -> State.session * string 146 | 147 | (** [send_otr session message] is [session', out, user_data], where 148 | [out] should be sent to the communication partner and 149 | [user_data] be presented to the user. Depending on the current 150 | [session] state and configured {!State.policy}, [out] can be 151 | encrypted, or the initiation of an OTR session, or the plain 152 | text. [session'] should be used in subsequent API calls. 153 | [user_data] contains more information on what happened with 154 | [message] (whether it was sent in plain, encrypted, or not at 155 | all). *) 156 | val send_otr : State.session -> string -> 157 | State.session * string option * 158 | [ `Warning of string | `Sent of string | `Sent_encrypted of string ] 159 | 160 | (** [end_otr session] is [session', out], which ends the OTR 161 | session. [out] should be sent to the communication partner, 162 | [session'] should be used in subsequent calls. *) 163 | val end_otr : State.session -> State.session * string option 164 | 165 | (** [handle session data] is [session', out, ret], which handles 166 | received data. [out] should be sent to the communication partner 167 | (might contain data to complete a handshake), [ret] should be 168 | presented to the user. [handle] potentially decrypts the 169 | incoming message, or proceeds in the handshake setup. 170 | [session'] should be used in subsequent calls. *) 171 | val handle : State.session -> string -> State.session * string option * State.ret list 172 | 173 | (** [start_smp session ~question shared_secret] is 174 | [session', out, ret], which starts the 175 | {{:https://en.wikipedia.org/wiki/Socialist_millionaire} 176 | socialist millionairs problem} if the [session] is already 177 | established, using potentially the [question] and 178 | [shared_secret]. [out] should be sent to the communication 179 | partner, and [ret] presented to the user. [session'] should be 180 | used in subsequent calls. *) 181 | val start_smp : State.session -> ?question:string -> string -> State.session * string option * State.ret list 182 | 183 | (** [abort_smp session] is [session', out, ret], which aborts an 184 | unfinished SMP. [out] should be sent to the communication 185 | patner, and [ret] presented to the user. [session'] should be used 186 | in subsequent calls. *) 187 | val abort_smp : State.session -> State.session * string option * State.ret list 188 | 189 | (** [answer_smp session secret] is [session', out, ret], which 190 | answers the SMP. [out] should be sent to the communication 191 | partner, and [ret] presented to the user. The given [secret] is 192 | compared (in a zero-knowledge style) with the communication 193 | partners secret. [session'] should be used in subsequent 194 | calls. *) 195 | val answer_smp : State.session -> string -> State.session * string option * State.ret list 196 | end 197 | 198 | (** Utilities *) 199 | module Utils : sig 200 | (** {2 Fingerprint Utilities} *) 201 | 202 | (** An OTR fingerprint is the [`SHA1] hash of the public key 203 | prepended with the key type. *) 204 | 205 | (** [their_fingerprint session] is [fp], the fingerprint of the 206 | communication partner ([None] if no session is established). *) 207 | val their_fingerprint : State.session -> string option 208 | 209 | (** [own_fingerprint dsa] is [fp], the fingerprint of the private 210 | DSA key. *) 211 | val own_fingerprint : Mirage_crypto_pk.Dsa.priv -> string 212 | end 213 | -------------------------------------------------------------------------------- /src/otr_ake.ml: -------------------------------------------------------------------------------- 1 | open Otr_state 2 | 3 | (* Monadic control-flow core. *) 4 | type error = 5 | | Unknown of string 6 | | Unexpected of bool 7 | | VersionMismatch 8 | | InstanceMismatch 9 | 10 | let instance_tag () = 11 | (* 32 bit random, >= 0x00000100 *) 12 | let tag = String.get_int32_be (Mirage_crypto_rng.generate 4) 0 in 13 | Int32.(logor tag 0x100l) 14 | 15 | let select_version ours theirs = 16 | let test v = List.mem v theirs in 17 | match List.filter test ours with 18 | | v::_ -> Some v 19 | | [] -> None 20 | 21 | let instances = function 22 | | `V2 -> None 23 | | `V3 -> Some (0l, instance_tag ()) 24 | 25 | let safe_parse f x = 26 | match f x with 27 | | Ok x -> Ok x 28 | | Error Otr_parser.Underflow -> Error (Unknown "underflow error while parsing") 29 | | Error Otr_parser.LeadingZero -> Error (Unknown "leading zero of a MPI while parsing") 30 | | Error (Otr_parser.Unknown x) -> Error (Unknown ("error while parsing: " ^ x)) 31 | 32 | let mac_sign_encrypt hmac ckey priv gx gy keyid = 33 | let pub = 34 | let pub = Mirage_crypto_pk.Dsa.pub_of_priv priv in 35 | Otr_crypto.OtrDsa.to_wire pub 36 | in 37 | let sigb = 38 | let gxmpi = Otr_builder.encode_data gx 39 | and gympi = Otr_builder.encode_data gy 40 | in 41 | let mb = Otr_crypto.mac ~key:hmac [ gxmpi ; gympi ; pub ; Otr_builder.encode_int keyid ] in 42 | Otr_crypto.OtrDsa.signature ~key:priv mb 43 | in 44 | let xb = pub ^ Otr_builder.encode_int keyid ^ sigb in 45 | Otr_crypto.crypt ~key:ckey ~ctr:0L xb 46 | 47 | let mac_verify hmac signature pub gx gy keyid = 48 | let gxmpi = Otr_builder.encode_data gx 49 | and gympi = Otr_builder.encode_data gy 50 | in 51 | let mb = Otr_crypto.mac ~key:hmac [ gxmpi ; gympi ; Otr_crypto.OtrDsa.to_wire pub ; Otr_builder.encode_int keyid ] in 52 | guard (Otr_crypto.OtrDsa.verify ~key:pub signature mb) (Unknown "DSA verification failed") 53 | 54 | (* authentication handshake *) 55 | let dh_commit ctx their_versions = 56 | match select_version ctx.config.versions their_versions with 57 | | None -> Error VersionMismatch 58 | | Some version -> 59 | let dh_secret, gx = Otr_crypto.gen_dh_secret () in 60 | let r = Otr_crypto.gen_symmetric_key () in 61 | let gxmpi = Otr_builder.encode_data gx in 62 | let gxmpi' = Otr_crypto.crypt ~key:r ~ctr:0L gxmpi in 63 | let h = Otr_crypto.hash gxmpi in 64 | let instances = instances version in 65 | let dh_commit = Otr_builder.dh_commit version instances gxmpi' h in 66 | let auth_state = AUTHSTATE_AWAITING_DHKEY (dh_commit, h, (dh_secret, gx), r) 67 | and message_state = MSGSTATE_PLAINTEXT (* not entirely sure about this.. *) 68 | and smp_state = SMPSTATE_EXPECT1 in 69 | let state = { auth_state ; message_state ; smp_state } in 70 | Ok ({ ctx with version ; instances ; state }, dh_commit) 71 | 72 | let dh_key_await_revealsig ctx buf = 73 | let dh_secret, gx = Otr_crypto.gen_dh_secret () in 74 | let out = Otr_builder.dh_key ctx.version ctx.instances gx in 75 | let auth_state = AUTHSTATE_AWAITING_REVEALSIG ((dh_secret, gx), buf) in 76 | let state = { ctx.state with auth_state } in 77 | ({ ctx with state }, out) 78 | 79 | let check_key_reveal_sig ctx (dh_secret, gx) r gy = 80 | let* gy = safe_parse Otr_parser.parse_gy gy in 81 | let* shared_secret = 82 | Option.to_result ~none:(Unknown "invalid DH public key") 83 | (Otr_crypto.dh_shared dh_secret gy) 84 | in 85 | let (ssid, c, c', m1, m2, m1', m2') = Otr_crypto.derive_keys shared_secret in 86 | let keyidb = 1l in 87 | let enc_sig = mac_sign_encrypt m1 c ctx.dsa gx gy keyidb in 88 | let mac = Otr_crypto.mac160 ~key:m2 enc_sig in 89 | let reveal_sig = Otr_builder.reveal_signature ctx.version ctx.instances r enc_sig mac in 90 | let auth_state = AUTHSTATE_AWAITING_SIG (reveal_sig, (ssid, c', m1', m2'), (dh_secret, gx), gy) in 91 | let state = { ctx.state with auth_state } in 92 | Ok ({ ctx with state }, reveal_sig) 93 | 94 | let keys previous_dh gy their_keyid = 95 | let dh = Otr_crypto.gen_dh_secret () 96 | and previous_gy = "" 97 | in 98 | { dh ; previous_dh ; our_keyid = 2l ; 99 | gy ; previous_gy ; their_keyid } 100 | 101 | let format_ssid ssid high = 102 | let f, s = String.(get_int32_be ssid 0, get_int32_be ssid 4) in 103 | Printf.sprintf "%s%08lx%s %s%08lx%s" 104 | (if high then "[" else "") f (if high then "]" else "") 105 | (if high then "" else "[") s (if high then "" else "]") 106 | 107 | let check_reveal_send_sig ctx (dh_secret, gy) dh_commit buf = 108 | let* r, enc_data, mac = safe_parse Otr_parser.parse_reveal buf in 109 | let* gxenc, hgx = safe_parse Otr_parser.parse_dh_commit dh_commit in 110 | let gx = Otr_crypto.crypt ~key:r ~ctr:0L gxenc in 111 | let hgx' = Otr_crypto.hash gx in 112 | let* () = guard (String.equal hgx hgx') (Unknown "hgx does not match hgx'") in 113 | let* gx = safe_parse Otr_parser.parse_gy gx in 114 | let* shared_secret = 115 | Option.to_result 116 | ~none:(Unknown "invalid DH public key") 117 | (Otr_crypto.dh_shared dh_secret gx) 118 | in 119 | let ssid, c, c', m1, m2, m1', m2' = Otr_crypto.derive_keys shared_secret in 120 | let mac' = Otr_crypto.mac160 ~key:m2 enc_data in 121 | let* () = guard (String.equal mac mac') (Unknown "mac does not match mac'") in 122 | let xb = Otr_crypto.crypt ~key:c ~ctr:0L enc_data in 123 | (* split into pubb, keyidb, sigb *) 124 | let* pubb, keyidb, sigb = safe_parse Otr_parser.parse_signature_data xb in 125 | let* () = mac_verify m1 sigb pubb gx gy keyidb in 126 | (* pick keyida *) 127 | let keyida = 1l in 128 | let enc_sig = mac_sign_encrypt m1' c' ctx.dsa gy gx keyida in 129 | let m = Otr_crypto.mac160 ~key:m2' enc_sig in 130 | let dh_keys = keys (dh_secret, gy) gx keyida in 131 | let high = false in 132 | let enc_data = { dh_keys ; symms = [] ; their_dsa = pubb ; ssid ; high } in 133 | let state = { 134 | auth_state = AUTHSTATE_NONE ; 135 | message_state = MSGSTATE_ENCRYPTED enc_data ; 136 | smp_state = SMPSTATE_EXPECT1 ; 137 | } in 138 | Ok ({ ctx with state }, 139 | Otr_builder.signature ctx.version ctx.instances enc_sig m, 140 | format_ssid ssid high) 141 | 142 | let check_sig ctx (ssid, c', m1', m2') (dh_secret, gx) gy signature = 143 | (* decrypt signature, verify it and macs *) 144 | let* enc_data, mac = safe_parse Otr_parser.decode_data signature in 145 | let* () = guard (String.length mac = 20) (Unknown "mac has wrong length") in 146 | let mymac = Otr_crypto.mac160 ~key:m2' enc_data in 147 | let* () = guard (String.equal mac mymac) (Unknown "mac do not match") in 148 | let dec = Otr_crypto.crypt ~key:c' ~ctr:0L enc_data in 149 | (* split into puba keyida siga(Ma) *) 150 | let* puba, keyida, siga = safe_parse Otr_parser.parse_signature_data dec in 151 | let* () = mac_verify m1' siga puba gy gx keyida in 152 | let dh_keys = keys (dh_secret, gx) gy keyida in 153 | let high = true in 154 | let enc_data = { dh_keys ; symms = [] ; their_dsa = puba ; ssid ; high } in 155 | let state = { 156 | auth_state = AUTHSTATE_NONE ; 157 | message_state = MSGSTATE_ENCRYPTED enc_data ; 158 | smp_state = SMPSTATE_EXPECT1 ; 159 | } in 160 | Ok ({ ctx with state }, format_ssid ssid high) 161 | 162 | let handle_commit_await_key ctx dh_c h version instances buf = 163 | let* () = guard (String.length buf >= 32) (Unknown "underflow") in 164 | let their_hash = String.sub buf (String.length buf - 32) 32 in 165 | if Otr_crypto.mpi_gt h their_hash then 166 | Ok (ctx, Some dh_c) 167 | else 168 | let* () = guard (List.mem version ctx.config.versions) (Unknown "version") in 169 | let ctx = { ctx with version ; instances } in 170 | let ctx, dh_key = dh_key_await_revealsig ctx buf in 171 | Ok (ctx, Some dh_key) 172 | 173 | let check_version_instances ctx version instances = 174 | let* ctx = 175 | match ctx.state.auth_state with 176 | | AUTHSTATE_NONE -> Ok { ctx with version } 177 | | _ -> 178 | let* () = guard (version = ctx.version) VersionMismatch in 179 | Ok ctx 180 | in 181 | match version, instances, ctx.instances with 182 | | `V3, Some (yoursend, yourrecv), Some (mysend, myrecv) when mysend = 0l -> 183 | let* () = guard ((yourrecv = myrecv) && (Int32.shift_right_logical yoursend 8 > 0l)) InstanceMismatch in 184 | Ok { ctx with instances = Some (yoursend, myrecv) } 185 | | `V3, Some (yoursend, yourrecv), Some (mysend, myrecv) -> 186 | let* () = guard ((yourrecv = myrecv) && (yoursend = mysend)) InstanceMismatch in 187 | Ok ctx 188 | | `V3, Some (yoursend, yourrecv), None -> 189 | if Int32.shift_right_logical yourrecv 8 = 0l then 190 | let myinstance = instance_tag () in 191 | Ok { ctx with instances = Some (yoursend, myinstance) } 192 | else (* other side has an encrypted session with us, but we do not *) 193 | if ctx.state.auth_state = AUTHSTATE_NONE then 194 | (* hack for interop with coy.im *) 195 | Ok { ctx with instances } 196 | else (* if this happens, shit hits the fan - let's talk V2 to have Builder:header not run into failed assertions *) 197 | Ok { ctx with version = `V2 } 198 | | `V2, _ , _ -> Ok ctx 199 | | _ -> Error InstanceMismatch 200 | 201 | let handle_auth ctx bytes = 202 | let open Otr_packet in 203 | let* version, typ, instances, buf = safe_parse Otr_parser.parse_header bytes in 204 | (* simultaneous open *) 205 | match typ, ctx.state.auth_state with 206 | | DH_COMMIT, AUTHSTATE_AWAITING_DHKEY (dh_c, h, _, _) -> 207 | let* ctx, out = handle_commit_await_key ctx dh_c h version instances buf in 208 | Ok (ctx, out, []) 209 | | _ -> 210 | let* ctx = check_version_instances ctx version instances in 211 | match typ, ctx.state.auth_state with 212 | | DH_COMMIT, AUTHSTATE_NONE -> 213 | let ctx, dh_key = dh_key_await_revealsig ctx buf in 214 | Ok (ctx, Some dh_key, []) 215 | | DH_COMMIT, AUTHSTATE_AWAITING_REVEALSIG ((dh_secret, gx), _) -> 216 | let auth_state = AUTHSTATE_AWAITING_REVEALSIG ((dh_secret, gx), buf) in 217 | let state = { ctx.state with auth_state } in 218 | let dh_key = Otr_builder.dh_key ctx.version ctx.instances gx in 219 | Ok ({ ctx with state }, Some dh_key, []) 220 | | DH_COMMIT, AUTHSTATE_AWAITING_SIG _ -> 221 | (* send dh_key, go to AWAITING_REVEALSIG *) 222 | let ctx, dh_key = dh_key_await_revealsig ctx buf in 223 | Ok (ctx, Some dh_key, []) 224 | 225 | | DH_KEY, AUTHSTATE_AWAITING_DHKEY (_, _, dh_params, r) -> 226 | (* reveal_sig -> AUTHSTATE_AWAITING_SIG *) 227 | let* ctx, reveal = check_key_reveal_sig ctx dh_params r buf in 228 | Ok (ctx, Some reveal, []) 229 | 230 | | DH_KEY, AUTHSTATE_AWAITING_SIG (reveal_sig, _, _, gy) -> 231 | (* same dh_key? -> retransmit REVEAL_SIG *) 232 | let* gy' = safe_parse Otr_parser.parse_gy buf in 233 | if String.equal gy gy' then 234 | Ok (ctx, Some reveal_sig, []) 235 | else 236 | Ok (ctx, None, []) 237 | 238 | | REVEAL_SIGNATURE, AUTHSTATE_AWAITING_REVEALSIG (dh_params, dh_commit) -> 239 | (* do work, send signature -> AUTHSTATE_NONE, MSGSTATE_ENCRYPTED *) 240 | let* ctx, out, ssid = check_reveal_send_sig ctx dh_params dh_commit buf in 241 | Ok (ctx, Some out, [`Established_encrypted_session ssid]) 242 | 243 | | SIGNATURE, AUTHSTATE_AWAITING_SIG (_, keys, dh_params, gy) -> 244 | (* decrypt signature, verify sig + macs -> AUTHSTATE_NONE, MSGSTATE_ENCRYPTED *) 245 | let* ctx, ssid = check_sig ctx keys dh_params gy buf in 246 | Ok (ctx, None, [`Established_encrypted_session ssid]) 247 | 248 | | DATA, _ -> 249 | let* flag, _, _, _, _, _, _, _ = 250 | safe_parse Otr_parser.parse_data_body buf 251 | in 252 | Error (Unexpected flag) 253 | 254 | | _ -> (* ignore this message *) Ok (ctx, None, [`Warning "ignoring unknown message"]) 255 | -------------------------------------------------------------------------------- /src/otr_ake.mli: -------------------------------------------------------------------------------- 1 | 2 | type error = 3 | | Unknown of string 4 | | Unexpected of bool 5 | | VersionMismatch 6 | | InstanceMismatch 7 | 8 | val dh_commit : Otr_state.session -> Otr_state.version list -> 9 | (Otr_state.session * string, error) result 10 | 11 | val handle_auth : Otr_state.session -> string -> 12 | (Otr_state.session * string option * Otr_state.ret list, error) result 13 | -------------------------------------------------------------------------------- /src/otr_builder.ml: -------------------------------------------------------------------------------- 1 | 2 | open Otr_state 3 | 4 | let int_of_version = function 5 | | `V2 -> 2 6 | | `V3 -> 3 7 | 8 | let query_message versions = 9 | let is v = List.mem v versions in 10 | match is `V2, is `V3 with 11 | | true, true -> otr_prefix ^ "v23?" 12 | | true, false -> otr_prefix ^ "v2?" 13 | | false, true -> otr_prefix ^ "v3?" 14 | | false, false -> otr_prefix ^ "v?" 15 | 16 | let tag versions = 17 | let is v = List.mem v versions in 18 | match is `V2, is `V3 with 19 | | true, true -> tag_prefix ^ tag_v3 ^ tag_v2 20 | | true, false -> tag_prefix ^ tag_v2 21 | | false, true -> tag_prefix ^ tag_v3 22 | | false, false -> "" 23 | 24 | let header version instances typ = 25 | let buf = match version with 26 | | `V2 -> Bytes.create 3 27 | | `V3 -> Bytes.create 11 28 | in 29 | Bytes.set_uint16_be buf 0 (int_of_version version) ; 30 | Bytes.set_uint8 buf 2 (Otr_packet.message_type_to_int typ) ; 31 | (match version, instances with 32 | | `V2, None -> () 33 | | `V3, Some (them, us) -> 34 | Bytes.set_int32_be buf 3 us ; 35 | Bytes.set_int32_be buf 7 them 36 | | _ -> assert false ); 37 | Bytes.unsafe_to_string buf 38 | 39 | let encode_int data = 40 | let buf = Bytes.create 4 in 41 | Bytes.set_int32_be buf 0 data ; 42 | Bytes.unsafe_to_string buf 43 | 44 | let encode_data data = 45 | encode_int (Int32.of_int (String.length data)) ^ data 46 | 47 | let dh_commit version instances dhshared hashed = 48 | let header = header version instances Otr_packet.DH_COMMIT in 49 | header ^ encode_data dhshared ^ encode_data hashed 50 | 51 | let dh_key version instances shared = 52 | let header = header version instances Otr_packet.DH_KEY in 53 | header ^ encode_data shared 54 | 55 | let reveal_signature version instances r enc_sig mac = 56 | let header = header version instances Otr_packet.REVEAL_SIGNATURE in 57 | header ^ encode_data r ^ encode_data enc_sig ^ mac 58 | 59 | let signature version instances enc mac = 60 | let header = header version instances Otr_packet.SIGNATURE in 61 | header ^ encode_data enc ^ mac 62 | 63 | let data version instances flags keyida keyidb dh_y ctr data = 64 | let header = header version instances Otr_packet.DATA in 65 | let keys = Bytes.create 9 in 66 | Bytes.set_uint8 keys 0 (if flags then 1 else 0) ; 67 | Bytes.set_int32_be keys 1 keyida ; 68 | Bytes.set_int32_be keys 5 keyidb ; 69 | let ctr = 70 | let buf = Bytes.create 8 in 71 | Bytes.set_int64_be buf 0 ctr ; 72 | buf 73 | in 74 | header ^ Bytes.unsafe_to_string keys ^ encode_data dh_y ^ Bytes.unsafe_to_string ctr ^ encode_data data 75 | 76 | let tlv ?data ?predata typ = 77 | let buf = Bytes.create 4 in 78 | Bytes.set_uint16_be buf 0 (Otr_packet.tlv_type_to_int typ) ; 79 | match data with 80 | | Some payload -> 81 | let llen = encode_int (Int32.of_int (List.length payload)) in 82 | let data = String.concat "" (llen :: List.map encode_data payload) in 83 | let pred = match predata with 84 | | None -> "" 85 | | Some x -> x 86 | in 87 | let data = pred ^ data in 88 | Bytes.set_uint16_be buf 2 (String.length data) ; 89 | Bytes.unsafe_to_string buf ^ data 90 | | None -> 91 | Bytes.set_uint16_be buf 2 0 ; 92 | Bytes.unsafe_to_string buf 93 | -------------------------------------------------------------------------------- /src/otr_builder.mli: -------------------------------------------------------------------------------- 1 | 2 | val query_message : Otr_state.version list -> string 3 | val tag : Otr_state.version list -> string 4 | val encode_int : int32 -> string 5 | val encode_data : string -> string 6 | val dh_commit : Otr_state.version -> (int32 * int32) option -> string -> string -> string 7 | val dh_key : Otr_state.version -> (int32 * int32) option -> string -> string 8 | val reveal_signature : Otr_state.version -> (int32 * int32) option -> string -> string -> string -> string 9 | val signature : Otr_state.version -> (int32 * int32) option -> string -> string -> string 10 | val data : Otr_state.version -> (int32 * int32) option -> bool -> int32 -> int32 -> string -> int64 -> string -> string 11 | 12 | val tlv : ?data:string list -> ?predata:string -> Otr_packet.tlv_type -> string 13 | -------------------------------------------------------------------------------- /src/otr_crypto.ml: -------------------------------------------------------------------------------- 1 | let encode_mpi n = 2 | Otr_builder.encode_data (Mirage_crypto_pk.Z_extra.to_octets_be n) 3 | 4 | let mpi_gt h1 h2 = 5 | Mirage_crypto_pk.Z_extra.(of_octets_be h1 > of_octets_be h2) 6 | 7 | module OtrDsa = struct 8 | open Mirage_crypto_pk.Dsa 9 | 10 | let pub ~p ~q ~gg ~y = 11 | (* TODO check whether they must be FIPS *) 12 | let z_of_cs = Mirage_crypto_pk.Z_extra.of_octets_be ?bits:None in 13 | Mirage_crypto_pk.Dsa.pub ~p:(z_of_cs p) ~q:(z_of_cs q) ~gg:(z_of_cs gg) ~y:(z_of_cs y) () 14 | 15 | let to_wire ?notag ({ p ; q ; gg ; y } : pub) = 16 | let tag = 17 | match notag with 18 | | None -> "\x00\x00" 19 | | Some _ -> "" 20 | in 21 | tag ^ encode_mpi p ^ encode_mpi q ^ encode_mpi gg ^ encode_mpi y 22 | 23 | let fingerprint k = 24 | (* only handling key type 0000, DSA *) 25 | Digestif.SHA1.(to_raw_string (digest_string (to_wire ~notag:() k))) 26 | 27 | let signature ~key data = 28 | let r, s = sign ~key (massage ~key:(pub_of_priv key) data) in 29 | r ^ s 30 | 31 | let verify ~key rs data = 32 | verify ~key rs (massage ~key data) 33 | end 34 | 35 | let derive_keys data = 36 | let secbytes = Otr_builder.encode_data data in 37 | let h2 b = 38 | Digestif.SHA256.(to_raw_string (digestv_string [ b ; secbytes ])) 39 | in 40 | let ssid = String.sub (h2 "\000") 0 8 in 41 | let c, c' = 42 | let data = h2 "\001" in 43 | String.sub data 0 16, 44 | String.sub data 16 (String.length data - 16) 45 | in 46 | let m1 = h2 "\002" in 47 | let m2 = h2 "\003" in 48 | let m1' = h2 "\004" in 49 | let m2' = h2 "\005" in 50 | (ssid, c, c', m1, m2, m1', m2') 51 | 52 | 53 | let data_keys data high = 54 | let secbytes = Otr_builder.encode_data data in 55 | let send, recv = if high then ("\001", "\002") else ("\002", "\001") in 56 | let h1 b = 57 | Digestif.SHA1.(to_raw_string (digestv_string [ b ; secbytes ])) 58 | in 59 | let sendaes = String.sub (h1 send) 0 16 in 60 | let sendmac = Digestif.SHA1.(to_raw_string (digest_string sendaes)) in 61 | let recvaes = String.sub (h1 recv) 0 16 in 62 | let recvmac = Digestif.SHA1.(to_raw_string (digest_string recvaes)) in 63 | (sendaes, sendmac, recvaes, recvmac) 64 | 65 | module AES_CTR = Mirage_crypto.AES.CTR 66 | 67 | let crypt ~key ~ctr msg = 68 | AES_CTR.encrypt ~key:(AES_CTR.of_secret key) ~ctr:(ctr, 0L) msg 69 | 70 | let gen_symmetric_key () = 71 | Mirage_crypto_rng.generate 16 72 | 73 | let hash data = 74 | Digestif.SHA256.(to_raw_string (digest_string data)) 75 | 76 | let mac ~key data = 77 | let data = String.concat "" data in 78 | Digestif.SHA256.(to_raw_string (hmac_string ~key data)) 79 | 80 | let mac160 ~key data = 81 | let buf = mac ~key [ Otr_builder.encode_data data ] in 82 | String.sub buf 0 20 83 | 84 | let sha1mac ~key data = 85 | Digestif.SHA1.(to_raw_string (hmac_string ~key data)) 86 | 87 | let group = Mirage_crypto_pk.Dh.Group.oakley_5 88 | 89 | let gen_dh_secret () = 90 | Mirage_crypto_pk.Dh.gen_key group 91 | 92 | let dh_shared = Mirage_crypto_pk.Dh.shared 93 | 94 | let check_gy gy = 95 | let open Mirage_crypto_pk in 96 | let gy = Z_extra.of_octets_be gy in 97 | gy <= Z.one || gy >= Z.(pred group.Dh.p) || gy = group.Dh.gg 98 | 99 | let smp_hash version mpis = 100 | let buf = Bytes.create 1 in 101 | Bytes.set_uint8 buf 0 version ; 102 | hash (String.concat "" (Bytes.unsafe_to_string buf :: List.map encode_mpi mpis)) 103 | 104 | let oakley_5_q = Z.((group.Mirage_crypto_pk.Dh.p - one) / (succ one)) 105 | 106 | let minus_mult_q a b c = 107 | (* OCaml mod: -5 mod 4 -> -1, but we need 3 instead *) 108 | let res = Z.((a - b * c) mod oakley_5_q) in 109 | if Z.(res < zero) then 110 | Z.(res + oakley_5_q) 111 | else 112 | res 113 | 114 | let proof_knowledge sec static = 115 | let open Mirage_crypto_pk in 116 | let r, pub = gen_dh_secret () in 117 | let pub = Z_extra.of_octets_be pub in 118 | let c = smp_hash static [pub] in 119 | let cz = Z_extra.of_octets_be c in 120 | let d = minus_mult_q r.Dh.x sec.Dh.x cz in 121 | (c, Z_extra.to_octets_be d) 122 | 123 | let powZ gz expz = 124 | Z.(powm gz expz group.Mirage_crypto_pk.Dh.p) 125 | 126 | let pow_s g exp = 127 | let gz = Mirage_crypto_pk.Z_extra.of_octets_be g 128 | and expz = exp.Mirage_crypto_pk.Dh.x 129 | in 130 | let res = powZ gz expz in 131 | Mirage_crypto_pk.Z_extra.to_octets_be res 132 | 133 | let mult_powZ a b e = 134 | let b = powZ b e in 135 | Z.(a * b mod group.Mirage_crypto_pk.Dh.p) 136 | 137 | let mult_pow a g exp = 138 | let open Mirage_crypto_pk in 139 | let az = Z_extra.of_octets_be a 140 | and gz = Z_extra.of_octets_be g 141 | and expz = Z_extra.of_octets_be exp 142 | in 143 | let res = mult_powZ az gz expz in 144 | Z_extra.to_octets_be res 145 | 146 | let check_proof g c d static = 147 | let open Mirage_crypto_pk in 148 | let gz = Z_extra.of_octets_be g 149 | and cz = Z_extra.of_octets_be c 150 | and dz = Z_extra.of_octets_be d 151 | in 152 | let m = group.Dh.p in 153 | let pub = Z.(powZ (succ one) dz * powZ gz cz mod m) in 154 | let c' = smp_hash static [ pub ] in 155 | String.equal c' c 156 | 157 | let proof_equal_coords g2 g3 r y static = 158 | let open Mirage_crypto_pk in 159 | let r1, gr1 = gen_dh_secret () 160 | and r2, _ = gen_dh_secret () 161 | in 162 | let a = powZ (Z_extra.of_octets_be g3) r1.Dh.x 163 | and b = mult_powZ (Z_extra.of_octets_be gr1) (Z_extra.of_octets_be g2) r2.Dh.x 164 | in 165 | let cp = smp_hash static [ a ; b ] in 166 | let cpz = Z_extra.of_octets_be cp in 167 | let d1 = minus_mult_q r1.Dh.x r.Dh.x cpz 168 | and d2 = minus_mult_q r2.Dh.x (Z_extra.of_octets_be y) cpz 169 | in 170 | (cp, Z_extra.to_octets_be d1, Z_extra.to_octets_be d2) 171 | 172 | let check_equal_coords g2 g3 pb qb cp d1 d2 static = 173 | let open Mirage_crypto_pk in 174 | let pbz = Z_extra.of_octets_be pb 175 | and qbz = Z_extra.of_octets_be qb 176 | and cpz = Z_extra.of_octets_be cp 177 | in 178 | let check n = Z.(n > one && n <= (pred (pred group.Dh.p))) in 179 | if check pbz && check qbz then 180 | let a = 181 | let a = powZ (Z_extra.of_octets_be g3) (Z_extra.of_octets_be d1) 182 | and b = powZ pbz cpz 183 | in 184 | Z.(a * b mod group.Dh.p) 185 | and b = 186 | let a = powZ Z.(succ one) (Z_extra.of_octets_be d1) 187 | and b = powZ (Z_extra.of_octets_be g2) (Z_extra.of_octets_be d2) 188 | and c = powZ qbz cpz 189 | in 190 | Z.(a * b * c mod group.Dh.p) 191 | in 192 | let cp' = smp_hash static [ a ; b ] in 193 | String.equal cp' cp 194 | else 195 | false 196 | 197 | let proof_eq_logs p a static = 198 | let open Mirage_crypto_pk in 199 | let pz = Z_extra.of_octets_be p in 200 | let r, gr = gen_dh_secret () in 201 | let cr = 202 | let a = Z_extra.of_octets_be gr 203 | and b = powZ pz r.Dh.x 204 | in 205 | smp_hash static [ a ; b ] 206 | in 207 | let d = minus_mult_q r.Dh.x a.Dh.x (Z_extra.of_octets_be cr) in 208 | (cr, Z_extra.to_octets_be d) 209 | 210 | let check_eq_logs c g p d r static = 211 | let open Mirage_crypto_pk in 212 | let rz = Z_extra.of_octets_be r in 213 | let check n = Z.(n > one && n <= (pred (pred group.Dh.p))) in 214 | if check rz then 215 | let dz = Z_extra.of_octets_be d 216 | and cz = Z_extra.of_octets_be c 217 | in 218 | let a = 219 | let a = powZ Z.(succ one) dz 220 | and b = powZ (Z_extra.of_octets_be g) cz 221 | in 222 | Z.(a * b mod group.Dh.p) 223 | and b = 224 | let a = powZ (Z_extra.of_octets_be p) dz 225 | and b = powZ rz cz 226 | in 227 | Z.(a * b mod group.Dh.p) 228 | in 229 | let c' = smp_hash static [ a ; b ] in 230 | String.equal c c' 231 | else 232 | false 233 | 234 | let compute_p pa pb = 235 | let open Mirage_crypto_pk in 236 | let paz = Z_extra.of_octets_be pa 237 | and pbz = Z_extra.of_octets_be pb 238 | in 239 | let p = Z.(paz * (invert pbz group.Dh.p) mod group.Dh.p) in 240 | Z_extra.to_octets_be p 241 | 242 | let prepare_secret initiator_fp responder_fp ssid secret = 243 | let version = "\001" in 244 | let data = version ^ initiator_fp ^ responder_fp ^ ssid ^ secret in 245 | hash data 246 | -------------------------------------------------------------------------------- /src/otr_crypto.mli: -------------------------------------------------------------------------------- 1 | 2 | val mpi_gt : string -> string -> bool 3 | 4 | module OtrDsa : sig 5 | val pub : p:string -> q:string -> gg:string -> y:string -> (Mirage_crypto_pk.Dsa.pub, [> `Msg of string ]) result 6 | val to_wire : ?notag:unit -> Mirage_crypto_pk.Dsa.pub -> string 7 | val fingerprint : Mirage_crypto_pk.Dsa.pub -> string 8 | val signature : key:Mirage_crypto_pk.Dsa.priv -> string -> string 9 | val verify : key:Mirage_crypto_pk.Dsa.pub -> string * string -> string -> bool 10 | end 11 | 12 | val derive_keys : string -> (string * string * string * string * string * string * string) 13 | val data_keys : string -> bool -> (string * string * string * string) 14 | 15 | val crypt : key:string -> ctr:int64 -> string -> string 16 | 17 | val gen_symmetric_key : unit -> string 18 | 19 | val hash : string -> string 20 | val mac : key:string -> string list -> string 21 | val mac160 : key:string -> string -> string 22 | val sha1mac : key:string -> string -> string 23 | 24 | val gen_dh_secret : unit -> (Mirage_crypto_pk.Dh.secret * string) 25 | val dh_shared : Mirage_crypto_pk.Dh.secret -> string -> string option 26 | val check_gy : string -> bool 27 | 28 | val pow_s : string -> Mirage_crypto_pk.Dh.secret -> string 29 | val mult_pow : string -> string -> string -> string 30 | 31 | val proof_knowledge : Mirage_crypto_pk.Dh.secret -> int -> (string * string) 32 | val check_proof : string -> string -> string -> int -> bool 33 | 34 | val proof_equal_coords : string -> string -> Mirage_crypto_pk.Dh.secret -> string -> int -> (string * string * string) 35 | val check_equal_coords : string -> string -> string -> string -> string -> string -> string -> int -> bool 36 | 37 | val proof_eq_logs : string -> Mirage_crypto_pk.Dh.secret -> int -> string * string 38 | val check_eq_logs : string -> string -> string -> string -> string -> int -> bool 39 | 40 | val compute_p : string -> string -> string 41 | 42 | val prepare_secret : string -> string -> string -> string -> string 43 | -------------------------------------------------------------------------------- /src/otr_packet.ml: -------------------------------------------------------------------------------- 1 | 2 | type message_type = 3 | | DH_COMMIT 4 | | DATA 5 | | DH_KEY 6 | | REVEAL_SIGNATURE 7 | | SIGNATURE 8 | 9 | let message_type_to_int = function 10 | | DH_COMMIT -> 2 11 | | DATA -> 3 12 | | DH_KEY -> 0x0a 13 | | REVEAL_SIGNATURE -> 0x11 14 | | SIGNATURE -> 0x12 15 | 16 | let int_to_message_type = function 17 | | 2 -> Some DH_COMMIT 18 | | 3 -> Some DATA 19 | | 0x0a -> Some DH_KEY 20 | | 0x11 -> Some REVEAL_SIGNATURE 21 | | 0x12 -> Some SIGNATURE 22 | | _ -> None 23 | 24 | type tlv_type = 25 | | PADDING 26 | | DISCONNECTED 27 | | SMP_MESSAGE_1 28 | | SMP_MESSAGE_2 29 | | SMP_MESSAGE_3 30 | | SMP_MESSAGE_4 31 | | SMP_ABORT 32 | | SMP_MESSAGE_1Q 33 | | EXTRA_SYMMETRIC_KEY 34 | 35 | let tlv_type_to_int = function 36 | | PADDING -> 0 37 | | DISCONNECTED -> 1 38 | | SMP_MESSAGE_1 -> 2 39 | | SMP_MESSAGE_2 -> 3 40 | | SMP_MESSAGE_3 -> 4 41 | | SMP_MESSAGE_4 -> 5 42 | | SMP_ABORT -> 6 43 | | SMP_MESSAGE_1Q -> 7 44 | | EXTRA_SYMMETRIC_KEY -> 8 45 | 46 | let int_to_tlv_type = function 47 | | 0 -> Some PADDING 48 | | 1 -> Some DISCONNECTED 49 | | 2 -> Some SMP_MESSAGE_1 50 | | 3 -> Some SMP_MESSAGE_2 51 | | 4 -> Some SMP_MESSAGE_3 52 | | 5 -> Some SMP_MESSAGE_4 53 | | 6 -> Some SMP_ABORT 54 | | 7 -> Some SMP_MESSAGE_1Q 55 | | 8 -> Some EXTRA_SYMMETRIC_KEY 56 | | _ -> None 57 | -------------------------------------------------------------------------------- /src/otr_packet.mli: -------------------------------------------------------------------------------- 1 | 2 | type message_type = 3 | | DH_COMMIT 4 | | DATA 5 | | DH_KEY 6 | | REVEAL_SIGNATURE 7 | | SIGNATURE 8 | 9 | val message_type_to_int : message_type -> int 10 | val int_to_message_type : int -> message_type option 11 | 12 | type tlv_type = 13 | | PADDING 14 | | DISCONNECTED 15 | | SMP_MESSAGE_1 16 | | SMP_MESSAGE_2 17 | | SMP_MESSAGE_3 18 | | SMP_MESSAGE_4 19 | | SMP_ABORT 20 | | SMP_MESSAGE_1Q 21 | | EXTRA_SYMMETRIC_KEY 22 | 23 | val tlv_type_to_int : tlv_type -> int 24 | val int_to_tlv_type : int -> tlv_type option 25 | -------------------------------------------------------------------------------- /src/otr_parser.ml: -------------------------------------------------------------------------------- 1 | open Otr_packet 2 | open Otr_state 3 | 4 | type error = 5 | | Unknown of string 6 | | Underflow 7 | | LeadingZero 8 | 9 | let maybe a = if a = "" then None else Some a 10 | 11 | (* parse query string *) 12 | let parse_query str = 13 | let parse_v acc = function 14 | | '2' -> `V2 :: acc 15 | | '3' -> `V3 :: acc 16 | | _ -> acc 17 | in 18 | let parse idx = 19 | let _, left = Astring.String.span ~max:idx str in 20 | match Astring.String.cut ~sep:"?" left with 21 | | None -> ([], None) 22 | | Some (vs, post) -> 23 | let versions = String.fold_left parse_v [] vs in 24 | (List.rev versions, maybe post) 25 | in 26 | match String.get str 0, String.get str 1 with 27 | | '?', 'v' -> Ok (parse 2) 28 | | 'v', _ -> Ok (parse 1) 29 | | _ -> Error (Unknown "no usable version found") 30 | 31 | let mark_match sep data = 32 | match Astring.String.cut ~sep data with 33 | | Some (pre, post) -> Ok (maybe pre, post) 34 | | None -> Error (Unknown "parse failed") 35 | 36 | type ret = [ 37 | | `Data of string 38 | | `ParseError of string 39 | | `Error of string 40 | | `PlainTag of Otr_state.version list * string option 41 | | `Query of Otr_state.version list 42 | | `String of string 43 | | `Fragment_v2 of (int * int) * string 44 | | `Fragment_v3 of (int32 * int32) * (int * int) * string 45 | ] 46 | 47 | let parse_data data = 48 | match Astring.String.cut ~sep:"." data with 49 | | None -> Error (Unknown "empty OTR message") 50 | | Some (data, rest) -> 51 | match Base64.decode data with 52 | | Ok x -> Ok (x, maybe rest) 53 | | Error (`Msg m) -> Error (Unknown ("bad base64 data: " ^ m)) 54 | 55 | let parse_plain_tag data = 56 | let rec find_mark str acc = 57 | if String.length str < 8 then 58 | (List.rev acc, maybe str) 59 | else 60 | let tag, rest = Astring.String.span ~max:8 str in 61 | if tag = Otr_state.tag_v2 then 62 | find_mark rest (`V2 :: acc) 63 | else if tag = Otr_state.tag_v3 then 64 | find_mark rest (`V3 :: acc) 65 | else 66 | find_mark rest acc 67 | in 68 | find_mark data [] 69 | 70 | let parse_fragment data = 71 | match Astring.String.cuts ~sep:"," data with 72 | | k :: n :: piece :: rest -> 73 | let k = int_of_string k in 74 | let n = int_of_string n in 75 | let* () = 76 | guard 77 | (k > 0 && k <= 65535) 78 | (Unknown "k must be between 0 and 65535") 79 | in 80 | let* () = 81 | guard 82 | (n > 0 && n <= 65535) 83 | (Unknown "n must be between 0 and 65535") 84 | in 85 | let* () = 86 | guard 87 | (k <= n) 88 | (Unknown "k must be smaller or equal to n") 89 | in 90 | let* () = 91 | guard 92 | (String.length piece > 0) 93 | (Unknown "fragment must be of non-zero size") 94 | in 95 | let* () = 96 | guard 97 | (String.length (String.concat "" rest) = 0) 98 | (Unknown "too many elements") 99 | in 100 | Ok ((k, n), piece) 101 | | _ -> Error (Unknown "invalid fragment") 102 | 103 | let parse_fragment_v3 data = 104 | match Astring.String.cut ~sep:"|" data with 105 | | Some (sender_instance, data) -> 106 | ( match Astring.String.cut ~sep:"," data with 107 | | Some (receiver_instance, data) -> 108 | let sender_instance = Scanf.sscanf sender_instance "%lx" (fun x -> x) in 109 | let receiver_instance = Scanf.sscanf receiver_instance "%lx" (fun x -> x) in 110 | let* kn, piece = parse_fragment data in 111 | Ok ((sender_instance, receiver_instance), kn, piece) 112 | | None -> Error (Unknown "invalid fragment (receiver_instance)")) 113 | | None -> Error (Unknown "invalid fragment (sender_instance)") 114 | 115 | let classify_input bytes = 116 | let open Otr_state in 117 | match mark_match otr_v2_frag bytes with 118 | | Ok (pre, data) -> 119 | begin match parse_fragment data with 120 | | Ok data when pre = None -> `Fragment_v2 data 121 | | Ok _ -> `ParseError "Malformed v2 fragment (predata)" 122 | | Error _ -> `ParseError "Malformed v2 fragment" 123 | end 124 | | Error _ -> match mark_match otr_v3_frag bytes with 125 | | Ok (pre, data) -> 126 | begin match parse_fragment_v3 data with 127 | | Ok data when pre = None -> `Fragment_v3 data 128 | | Ok _ -> `ParseError "Malformed v3 fragment (predata)" 129 | | Error _ -> `ParseError "Malformed v3 fragment" 130 | end 131 | | Error _ -> match mark_match otr_mark bytes with 132 | | Ok (pre, data) -> 133 | begin match parse_data data with 134 | | Ok (data, post) when pre = None && post = None -> `Data data 135 | | Ok _ -> `ParseError "Malformed OTR data (pre/postdata)" 136 | | Error _ -> `ParseError "Malformed OTR data message" 137 | end 138 | | Error _ -> match mark_match otr_err_mark bytes with 139 | | Ok (pre, data) when pre = None -> `Error data 140 | | Ok _ -> `ParseError "Malformed Error received (predata)" 141 | | Error _ -> match mark_match otr_prefix bytes with 142 | | Ok (pre, data) -> 143 | begin match parse_query data with 144 | | Ok (versions, _) when pre = None -> `Query versions 145 | | Ok _ -> `ParseError "Malformed OTR query (pre/postdata)" 146 | | Error _ -> `ParseError "Malformed OTR query" 147 | end 148 | | Error _ -> match mark_match tag_prefix bytes with 149 | | Ok (pre, data) -> 150 | begin match parse_plain_tag data with 151 | | (versions, None) -> `PlainTag (versions, pre) 152 | | _ -> `ParseError "Malformed Tag (postdata)" 153 | end 154 | | Error _ -> `String bytes 155 | 156 | 157 | (* real OTR data parsing *) 158 | let decode_data buf = 159 | let* () = guard (String.length buf >= 4) Underflow in 160 | let size = Stdlib.String.get_int32_be buf 0 in 161 | let intsize = Int32.to_int size in 162 | let* () = guard (String.length buf >= 4 + intsize) Underflow in 163 | Ok (String.sub buf 4 intsize, String.sub buf (4 + intsize) (String.length buf - (4 + intsize))) 164 | 165 | let parse_gy data = 166 | let* gy, rst = decode_data data in 167 | let* () = guard (String.length rst = 0) Underflow in 168 | let* () = guard (String.get_uint8 gy 0 <> 0) LeadingZero in 169 | Ok gy 170 | 171 | 172 | let version_of_int = function 173 | | 2 -> Ok `V2 174 | | 3 -> Ok `V3 175 | | _ -> Error (Unknown "version") 176 | 177 | let parse_header bytes = 178 | let* () = guard (String.length bytes >= 3) Underflow in 179 | let* version = version_of_int (String.get_uint16_be bytes 0) in 180 | let typ = String.get_uint8 bytes 2 in 181 | let* typ = 182 | Option.to_result 183 | ~none:(Unknown "message type") 184 | (int_to_message_type typ) 185 | in 186 | match version with 187 | | `V2 -> Ok (version, typ, None, String.sub bytes 3 (String.length bytes - 3)) 188 | | `V3 -> 189 | let* () = guard (String.length bytes >= 11) Underflow in 190 | let mine = String.get_int32_be bytes 3 191 | and thei = String.get_int32_be bytes 7 192 | in 193 | Ok (version, typ, Some (mine, thei), String.sub bytes 11 (String.length bytes - 11)) 194 | 195 | let parse_signature_data buf = 196 | let* () = guard (String.length buf >= 2) Underflow in 197 | let tag, buf = String.sub buf 0 2, String.sub buf 2 (String.length buf - 2) in 198 | let* () = guard (String.get_uint16_be tag 0 = 0) (Unknown "key tag != 0") in 199 | let* p, buf = decode_data buf in 200 | let* () = guard (String.get_uint8 p 0 <> 0) LeadingZero in 201 | let* q, buf = decode_data buf in 202 | let* () = guard (String.get_uint8 q 0 <> 0) LeadingZero in 203 | let* gg, buf = decode_data buf in 204 | let* () = guard (String.get_uint8 gg 0 <> 0) LeadingZero in 205 | let* y, buf = decode_data buf in 206 | let* () = guard (String.get_uint8 y 0 <> 0) LeadingZero in 207 | let* key = 208 | Result.map_error 209 | (function `Msg m -> Unknown m) 210 | (Otr_crypto.OtrDsa.pub ~p ~q ~gg ~y) 211 | in 212 | let* () = guard (String.length buf = 44) (Unknown "signature lengh") in 213 | let keyida = String.get_int32_be buf 0 in 214 | let siga = 215 | String.sub buf 4 20, 216 | String.sub buf 24 (String.length buf - 24) 217 | in 218 | Ok (key, keyida, siga) 219 | 220 | let parse_reveal buf = 221 | let* r, buf = decode_data buf in 222 | let* enc_data, mac = decode_data buf in 223 | let* () = guard (String.length mac = 20) (Unknown "wrong mac length") in 224 | Ok (r, enc_data, mac) 225 | 226 | let parse_dh_commit buf = 227 | let* gxenc, buf = decode_data buf in 228 | let* hgx, buf = decode_data buf in 229 | let* () = 230 | guard ((String.length buf = 0) && (String.length hgx = 32)) (Unknown "bad dh_commit") 231 | in 232 | Ok (gxenc, hgx) 233 | 234 | let parse_data_body buf = 235 | let* () = guard (String.length buf >= 9) Underflow in 236 | let flags = String.get_uint8 buf 0 237 | and s_keyid = String.get_int32_be buf 1 238 | and r_keyid = String.get_int32_be buf 5 239 | in 240 | let* dh_y, buf = decode_data (String.sub buf 9 (String.length buf - 9)) in 241 | let* () = guard (String.get_uint8 dh_y 0 <> 0) LeadingZero in 242 | let* () = guard (String.length buf >= 8) Underflow in 243 | let ctr = String.get_int64_be buf 0 in 244 | let* encdata, buf = decode_data (String.sub buf 8 (String.length buf - 8)) in 245 | let* () = guard (String.length buf >= 20) Underflow in 246 | let mac = String.sub buf 0 20 in 247 | let* reveal, buf = decode_data (String.sub buf 20 (String.length buf - 20)) in 248 | let* () = guard (String.length buf = 0) Underflow in 249 | let flags = if flags = 1 then true else false in 250 | Ok (flags, s_keyid, r_keyid, dh_y, ctr, encdata, mac, reveal) 251 | 252 | let parse_data buf = 253 | let* version, typ, instances, buf = parse_header buf in 254 | let* () = guard (typ = DATA) (Unknown "type") in 255 | let* flags, s_keyid, r_keyid, dh_y, ctr, encdata, mac, reveal = 256 | parse_data_body buf 257 | in 258 | Ok (version, instances, flags, s_keyid, r_keyid, dh_y, ctr, encdata, mac, reveal) 259 | 260 | let parse_tlv buf = 261 | let* () = guard (String.length buf >= 4) Underflow in 262 | let typ = String.get_uint16_be buf 0 in 263 | let l = String.get_uint16_be buf 2 in 264 | let* () = guard (String.length buf >= 4 + l) Underflow in 265 | Ok (int_to_tlv_type typ, String.sub buf 4 l, String.sub buf (4 + l) (String.length buf - (4 + l))) 266 | 267 | let parse_datas buf n = 268 | let rec p_data buf acc = function 269 | | 0 when String.length buf = 0 -> Ok (List.rev acc) 270 | | 0 -> Error Underflow 271 | | n -> 272 | let* x, buf = decode_data buf in 273 | let* () = guard (String.get_uint8 x 0 <> 0) LeadingZero in 274 | p_data buf (x :: acc) (pred n) 275 | in 276 | let* () = guard (String.length buf >= 4) Underflow in 277 | let cnt = String.get_int32_be buf 0 in 278 | if cnt = Int32.of_int n then 279 | p_data (String.sub buf 4 (String.length buf - 4)) [] n 280 | else 281 | Error Underflow 282 | -------------------------------------------------------------------------------- /src/otr_parser.mli: -------------------------------------------------------------------------------- 1 | type error = 2 | | Unknown of string 3 | | Underflow 4 | | LeadingZero 5 | 6 | type ret = [ 7 | | `Data of string 8 | | `ParseError of string 9 | | `Error of string 10 | | `PlainTag of Otr_state.version list * string option 11 | | `Query of Otr_state.version list 12 | | `String of string 13 | | `Fragment_v2 of (int * int) * string 14 | | `Fragment_v3 of (int32 * int32) * (int * int) * string 15 | ] 16 | 17 | val classify_input : string -> ret 18 | 19 | val decode_data : string -> (string * string, error) result 20 | val parse_gy : string -> (string, error) result 21 | val parse_header : string -> (Otr_state.version * Otr_packet.message_type * (int32 * int32) option * string, error) result 22 | val parse_signature_data : string -> (Mirage_crypto_pk.Dsa.pub * int32 * (string * string), error) result 23 | val parse_reveal : string -> (string * string * string, error) result 24 | val parse_dh_commit : string -> (string * string, error) result 25 | val parse_data : string -> (Otr_state.version * (int32 * int32) option * bool * int32 * int32 * string * int64 * string * string * string, error) result 26 | val parse_data_body : string -> (bool * int32 * int32 * string * int64 * string * string * string, error) result 27 | 28 | val parse_query : string -> (Otr_state.version list * string option, error) result 29 | 30 | val parse_tlv : string -> (Otr_packet.tlv_type option * string * string, error) result 31 | 32 | val parse_datas : string -> int -> (string list, error) result 33 | -------------------------------------------------------------------------------- /src/otr_ratchet.ml: -------------------------------------------------------------------------------- 1 | open Otr_state 2 | 3 | let check_keys dh_keys send recv gy = 4 | match 5 | dh_keys.their_keyid = send, 6 | dh_keys.their_keyid = Int32.succ send, 7 | dh_keys.our_keyid = recv, 8 | dh_keys.our_keyid = Int32.succ recv 9 | with 10 | | false, false, _ , _ -> Some "wrong send keyid" 11 | | _ , _ , false, false -> Some "wrong receive keyid" 12 | | _ , _ , _ , _ -> 13 | match 14 | Otr_crypto.check_gy gy, 15 | dh_keys.their_keyid = Int32.succ send, 16 | String.length dh_keys.previous_gy = 0 17 | with 18 | | true, _ , _ -> Some "invalid gy" 19 | | _ , true, true -> Some "invalid previous gy" 20 | | _ , _ , _ -> None 21 | 22 | let rotate_our_keys dhs recv = 23 | if dhs.our_keyid = recv then 24 | { dhs with our_keyid = Int32.succ dhs.our_keyid ; 25 | previous_dh = dhs.dh ; 26 | dh = Otr_crypto.gen_dh_secret () } 27 | else 28 | dhs 29 | 30 | let rotate_their_keys dhs send dh_y = 31 | if dhs.their_keyid = send then 32 | { dhs with their_keyid = Int32.succ send ; 33 | previous_gy = dhs.gy ; 34 | gy = dh_y } 35 | else 36 | dhs 37 | 38 | let rotate_keys dh_keys send recv dh_y = 39 | rotate_their_keys (rotate_our_keys dh_keys recv) send dh_y 40 | 41 | let setup_keys (dh_secret, gx) gy = 42 | let high = Otr_crypto.mpi_gt gx gy in 43 | match Otr_crypto.dh_shared dh_secret gy with 44 | | None -> assert false (* can never happen, parameters have been checked earlier! *) 45 | | Some shared -> 46 | let send_aes, send_mac, recv_aes, recv_mac = Otr_crypto.data_keys shared high in 47 | { send_aes ; send_mac ; send_ctr = 0L ; recv_aes ; recv_mac ; recv_ctr = 0L } 48 | 49 | let find_keys keylist send recv = 50 | let rec go = function 51 | | [] -> None 52 | | (s, r, ks)::_ when s = send && r = recv -> Some ks 53 | | _::xs -> go xs 54 | in 55 | go keylist 56 | 57 | let keys dh_keys symm_keys send recv = 58 | match find_keys symm_keys send recv with 59 | | None -> 60 | let gy = if dh_keys.their_keyid = send then dh_keys.gy else dh_keys.previous_gy 61 | and dh = if dh_keys.our_keyid = recv then dh_keys.dh else dh_keys.previous_dh 62 | in 63 | let symm = setup_keys dh gy in 64 | ((send, recv, symm)::symm_keys, symm) 65 | | Some x -> 66 | (symm_keys, x) 67 | 68 | let rec update_counter update send recv = function 69 | | (s, r, k)::xs when s = send && r = recv -> (s, r, update k)::xs 70 | | x::xs -> x :: (update_counter update send recv xs) 71 | | [] -> [] 72 | 73 | let set_recv_counter newctr = 74 | update_counter (fun k -> { k with recv_ctr = newctr }) 75 | 76 | let inc_send_counter = 77 | let update = (fun k -> { k with send_ctr = Int64.succ k.send_ctr }) in 78 | update_counter update 79 | 80 | let rec erase_keys p = function 81 | | [] -> ([], []) 82 | | x::xs when p x -> 83 | let keep, destroy = erase_keys p xs in 84 | (keep, x :: destroy) 85 | | x::xs -> 86 | let keep, destroy = erase_keys p xs in 87 | (x :: keep, destroy) 88 | 89 | let erase_recv_keys recv = 90 | erase_keys (fun (_, r, _) -> r = recv) 91 | 92 | let erase_send_keys send = 93 | erase_keys (fun (s, _, _) -> s = send) 94 | 95 | let reveal dh_keys symm = 96 | let recv = Int32.pred (Int32.pred dh_keys.our_keyid) 97 | and send = Int32.pred (Int32.pred dh_keys.their_keyid) 98 | in 99 | let symm, erased = erase_recv_keys recv symm in 100 | let symm, erased2 = erase_send_keys send symm in 101 | let third (_, _, x) = x in 102 | (symm, List.map third (erased @ erased2)) 103 | -------------------------------------------------------------------------------- /src/otr_ratchet.mli: -------------------------------------------------------------------------------- 1 | 2 | open Otr_state 3 | 4 | val check_keys : dh_keys -> int32 -> int32 -> string -> string option 5 | 6 | val keys : dh_keys -> symms -> int32 -> int32 -> symms * symmetric_keys 7 | 8 | val rotate_keys : dh_keys -> int32 -> int32 -> string -> dh_keys 9 | 10 | val set_recv_counter : int64 -> int32 -> int32 -> symms -> symms 11 | val inc_send_counter : int32 -> int32 -> symms -> symms 12 | 13 | val reveal : dh_keys -> symms -> symms * symmetric_keys list 14 | -------------------------------------------------------------------------------- /src/otr_smp.ml: -------------------------------------------------------------------------------- 1 | open Otr_state 2 | 3 | type error = 4 | | UnexpectedMessage 5 | | InvalidZeroKnowledgeProof 6 | 7 | let error_to_string = function 8 | | UnexpectedMessage -> "unexpected SMP message" 9 | | InvalidZeroKnowledgeProof -> "invalid zero knowledge proof" 10 | 11 | let fp = Otr_crypto.OtrDsa.fingerprint 12 | let my_fp dsa = fp (Mirage_crypto_pk.Dsa.pub_of_priv dsa) 13 | 14 | let start_smp dsa enc_data smp_state ?question secret = 15 | let* () = 16 | match smp_state with 17 | | SMPSTATE_EXPECT1 -> Ok () 18 | | _ -> Error UnexpectedMessage 19 | in 20 | let a2, g2a = Otr_crypto.gen_dh_secret () 21 | and a3, g3a = Otr_crypto.gen_dh_secret () 22 | in 23 | let c2, d2 = Otr_crypto.proof_knowledge a2 1 24 | and c3, d3 = Otr_crypto.proof_knowledge a3 2 25 | in 26 | let x = Otr_crypto.prepare_secret (my_fp dsa) (fp enc_data.their_dsa) enc_data.ssid secret in 27 | let data = [ g2a ; c2 ; d2 ; g3a ; c3 ; d3 ] 28 | and smp_state = SMPSTATE_EXPECT2 (x, a2, a3) 29 | in 30 | let out = match question with 31 | | None -> Otr_builder.tlv ~data Otr_packet.SMP_MESSAGE_1 32 | | Some x -> Otr_builder.tlv ~data ~predata:(x ^ "\000") Otr_packet.SMP_MESSAGE_1Q 33 | in 34 | Ok (smp_state, Some out) 35 | 36 | let abort_smp smp_state = 37 | match smp_state with 38 | | SMPSTATE_EXPECT1 -> Ok (SMPSTATE_EXPECT1, None) 39 | | _ -> Ok (SMPSTATE_EXPECT1, Some (Otr_builder.tlv Otr_packet.SMP_ABORT)) 40 | 41 | let handle_smp_1 data = 42 | match Otr_parser.parse_datas data 6 with 43 | | Error _ -> Error UnexpectedMessage 44 | | Ok xs -> 45 | let g2a = List.nth xs 0 46 | and c2 = List.nth xs 1 47 | and d2 = List.nth xs 2 48 | and g3a = List.nth xs 3 49 | and c3 = List.nth xs 4 50 | and d3 = List.nth xs 5 51 | in 52 | if Otr_crypto.check_proof g2a c2 d2 1 && Otr_crypto.check_proof g3a c3 d3 2 then 53 | Ok (SMPSTATE_WAIT_FOR_Y (g2a, g3a), None, [ `SMP_awaiting_secret ]) 54 | else 55 | Error InvalidZeroKnowledgeProof 56 | 57 | let handle_secret dsa enc_data smp_state secret = 58 | match smp_state with 59 | | SMPSTATE_WAIT_FOR_Y (g2a, g3a) -> 60 | let b2, g2b = Otr_crypto.gen_dh_secret () 61 | and b3, g3b = Otr_crypto.gen_dh_secret () 62 | in 63 | let c2, d2 = Otr_crypto.proof_knowledge b2 3 64 | and c3, d3 = Otr_crypto.proof_knowledge b3 4 65 | in 66 | ( match Otr_crypto.dh_shared b2 g2a, Otr_crypto.dh_shared b3 g3a with 67 | | Some g2, Some g3 -> 68 | let r, gr = Otr_crypto.gen_dh_secret () 69 | and y = Otr_crypto.prepare_secret (fp enc_data.their_dsa) (my_fp dsa) enc_data.ssid secret 70 | in 71 | let pb = Otr_crypto.pow_s g3 r 72 | and qb = Otr_crypto.mult_pow gr g2 y 73 | in 74 | let cp, d5, d6 = Otr_crypto.proof_equal_coords g2 g3 r y 5 in 75 | let out = Otr_builder.tlv ~data:[ g2b ; c2 ; d2 ; g3b ; c3 ; d3 ; pb ; qb ; cp ; d5 ; d6 ] Otr_packet.SMP_MESSAGE_2 76 | and smp_state = SMPSTATE_EXPECT3 (g3a, g2, g3, b3, pb, qb) 77 | in 78 | Ok (smp_state, Some out) 79 | | _ -> Error UnexpectedMessage ) 80 | | _ -> Error UnexpectedMessage 81 | 82 | let handle_smp_2 x a2 a3 data = 83 | match Otr_parser.parse_datas data 11 with 84 | | Error _ -> Error UnexpectedMessage 85 | | Ok xs -> 86 | let g2b = List.nth xs 0 87 | and c2 = List.nth xs 1 88 | and d2 = List.nth xs 2 89 | and g3b = List.nth xs 3 90 | and c3 = List.nth xs 4 91 | and d3 = List.nth xs 5 92 | and pb = List.nth xs 6 93 | and qb = List.nth xs 7 94 | and cp = List.nth xs 8 95 | and d5 = List.nth xs 9 96 | and d6 = List.nth xs 10 97 | in 98 | if Otr_crypto.check_proof g2b c2 d2 3 && Otr_crypto.check_proof g3b c3 d3 4 then 99 | match Otr_crypto.dh_shared a2 g2b, Otr_crypto.dh_shared a3 g3b with 100 | | Some g2, Some g3 -> 101 | if Otr_crypto.check_equal_coords g2 g3 pb qb cp d5 d6 5 then 102 | let r, gr = Otr_crypto.gen_dh_secret () in 103 | let pa = Otr_crypto.pow_s g3 r 104 | and qa = Otr_crypto.mult_pow gr g2 x 105 | in 106 | let cp, d5, d6 = Otr_crypto.proof_equal_coords g2 g3 r x 6 in 107 | let pab = Otr_crypto.compute_p pa pb 108 | and qab = Otr_crypto.compute_p qa qb 109 | in 110 | let ra = Otr_crypto.pow_s qab a3 111 | and cr, d7 = Otr_crypto.proof_eq_logs qab a3 7 112 | in 113 | let out = Otr_builder.tlv ~data:[ pa ; qa ; cp ; d5 ; d6 ; ra ; cr ; d7 ] Otr_packet.SMP_MESSAGE_3 114 | and smp_state = SMPSTATE_EXPECT4 (g3b, pab, qab, a3) 115 | in 116 | Ok (smp_state, out) 117 | else 118 | Error UnexpectedMessage 119 | | _ -> Error UnexpectedMessage 120 | else 121 | Error UnexpectedMessage 122 | 123 | let handle_smp_3 g3a g2 g3 b3 pb qb data = 124 | match Otr_parser.parse_datas data 8 with 125 | | Error _ -> Error UnexpectedMessage 126 | | Ok xs -> 127 | let pa = List.nth xs 0 128 | and qa = List.nth xs 1 129 | and cp = List.nth xs 2 130 | and d5 = List.nth xs 3 131 | and d6 = List.nth xs 4 132 | and ra = List.nth xs 5 133 | and cr = List.nth xs 6 134 | and d7 = List.nth xs 7 135 | in 136 | if Otr_crypto.check_equal_coords g2 g3 pa qa cp d5 d6 6 then 137 | let pab = Otr_crypto.compute_p pa pb 138 | and qab = Otr_crypto.compute_p qa qb 139 | in 140 | if Otr_crypto.check_eq_logs cr g3a qab d7 ra 7 then 141 | let rb = Otr_crypto.pow_s qab b3 142 | and cr, d7 = Otr_crypto.proof_eq_logs qab b3 8 143 | in 144 | let out = Otr_builder.tlv ~data:[ rb ; cr ; d7 ] Otr_packet.SMP_MESSAGE_4 in 145 | let rab = Otr_crypto.pow_s ra b3 in 146 | let ret = 147 | if String.equal rab pab then 148 | `SMP_success 149 | else 150 | `SMP_failure 151 | in 152 | let smp_state = SMPSTATE_EXPECT1 in 153 | Ok (smp_state, out, ret) 154 | else 155 | Error UnexpectedMessage 156 | else 157 | Error UnexpectedMessage 158 | 159 | let handle_smp_4 g3b pab qab a3 data = 160 | match Otr_parser.parse_datas data 3 with 161 | | Error _ -> Error UnexpectedMessage 162 | | Ok xs -> 163 | let rb = List.nth xs 0 164 | and cr = List.nth xs 1 165 | and d7 = List.nth xs 2 166 | in 167 | if Otr_crypto.check_eq_logs cr g3b qab d7 rb 8 then 168 | let rab = Otr_crypto.pow_s rb a3 in 169 | let ret = 170 | if String.equal rab pab then 171 | `SMP_success 172 | else 173 | `SMP_failure 174 | in 175 | Ok (SMPSTATE_EXPECT1, ret) 176 | else 177 | Error UnexpectedMessage 178 | 179 | let handle_smp smp_state typ data = 180 | let open Otr_packet in 181 | match smp_state, typ with 182 | | SMPSTATE_EXPECT1, SMP_MESSAGE_1 -> 183 | handle_smp_1 data 184 | | SMPSTATE_EXPECT1, SMP_MESSAGE_1Q -> 185 | let* question, data = 186 | try 187 | let stop = String.index data '\000' in 188 | let stop' = succ stop in 189 | Ok (String.sub data 0 stop, String.sub data stop' (String.length data - stop')) 190 | with 191 | Not_found -> Error UnexpectedMessage 192 | in 193 | let* s, o, r = handle_smp_1 data in 194 | Ok (s, o, [ `SMP_received_question question ] @ r) 195 | | SMPSTATE_EXPECT2 (x, a2, a3), SMP_MESSAGE_2 -> 196 | let* s, o = handle_smp_2 x a2 a3 data in 197 | Ok (s, Some o, []) 198 | | SMPSTATE_EXPECT3 (g3a, g2, g3, b3, pb, qb), SMP_MESSAGE_3 -> 199 | let* s, o, r = handle_smp_3 g3a g2 g3 b3 pb qb data in 200 | Ok (s, Some o, [r]) 201 | | SMPSTATE_EXPECT4 (g3b, pab, qab, ra), SMP_MESSAGE_4 -> 202 | let* s, r = handle_smp_4 g3b pab qab ra data in 203 | Ok (s, None, [r]) 204 | | _, SMP_ABORT -> 205 | Ok (SMPSTATE_EXPECT1, None, []) 206 | | _, _ -> 207 | let abort = Otr_builder.tlv SMP_ABORT in 208 | Ok (SMPSTATE_EXPECT1, Some abort, []) 209 | -------------------------------------------------------------------------------- /src/otr_smp.mli: -------------------------------------------------------------------------------- 1 | 2 | type error = 3 | | UnexpectedMessage 4 | | InvalidZeroKnowledgeProof 5 | 6 | val error_to_string : error -> string 7 | 8 | val start_smp : Mirage_crypto_pk.Dsa.priv -> Otr_state.enc_data -> Otr_state.smp_state -> ?question:string -> string -> (Otr_state.smp_state * string option, error) result 9 | 10 | val abort_smp : Otr_state.smp_state -> (Otr_state.smp_state * string option, error) result 11 | 12 | val handle_smp : Otr_state.smp_state -> Otr_packet.tlv_type -> string -> (Otr_state.smp_state * string option * Otr_state.ret list, error) result 13 | 14 | val handle_secret : Mirage_crypto_pk.Dsa.priv -> Otr_state.enc_data -> Otr_state.smp_state -> string -> (Otr_state.smp_state * string option, error) result 15 | -------------------------------------------------------------------------------- /src/otr_state.ml: -------------------------------------------------------------------------------- 1 | type ret = [ 2 | | `Warning of string 3 | | `Received_error of string 4 | | `Received of string 5 | | `Established_encrypted_session of string 6 | | `Received_encrypted of string 7 | | `SMP_awaiting_secret 8 | | `SMP_received_question of string 9 | | `SMP_success 10 | | `SMP_failure 11 | ] 12 | 13 | type dh_params = (Mirage_crypto_pk.Dh.secret * string) 14 | 15 | type dh_keys = { 16 | dh : dh_params ; 17 | previous_dh : dh_params ; 18 | our_keyid : int32 ; 19 | gy : string ; 20 | previous_gy : string ; 21 | their_keyid : int32 ; 22 | } 23 | 24 | type symmetric_keys = { 25 | send_aes : string ; 26 | send_mac : string ; 27 | send_ctr : int64 ; 28 | recv_aes : string ; 29 | recv_mac : string ; 30 | recv_ctr : int64 ; 31 | } 32 | 33 | type symms = (int32 * int32 * symmetric_keys) list 34 | 35 | type enc_data = { 36 | dh_keys : dh_keys ; 37 | symms : symms ; 38 | their_dsa : Mirage_crypto_pk.Dsa.pub ; 39 | ssid : string ; 40 | high : bool ; 41 | } 42 | 43 | type message_state = 44 | | MSGSTATE_PLAINTEXT 45 | | MSGSTATE_ENCRYPTED of enc_data 46 | | MSGSTATE_FINISHED 47 | 48 | let message_state_to_string = function 49 | | MSGSTATE_PLAINTEXT -> "plain" 50 | | MSGSTATE_ENCRYPTED _ -> "encrypted" 51 | | MSGSTATE_FINISHED -> "finished" 52 | 53 | type auth_state = 54 | | AUTHSTATE_NONE 55 | | AUTHSTATE_AWAITING_DHKEY of string * string * dh_params * string 56 | | AUTHSTATE_AWAITING_REVEALSIG of dh_params * string 57 | | AUTHSTATE_AWAITING_SIG of string * (string * string * string * string) * dh_params * string 58 | 59 | let auth_state_to_string = function 60 | | AUTHSTATE_NONE -> "none" 61 | | AUTHSTATE_AWAITING_DHKEY _ -> "awaiting dh key" 62 | | AUTHSTATE_AWAITING_REVEALSIG _ -> "awaiting reveal signature" 63 | | AUTHSTATE_AWAITING_SIG _ -> "awaiting signature" 64 | 65 | type smp_state = 66 | | SMPSTATE_WAIT_FOR_Y of string * string 67 | | SMPSTATE_EXPECT1 68 | | SMPSTATE_EXPECT2 of string * Mirage_crypto_pk.Dh.secret * Mirage_crypto_pk.Dh.secret 69 | | SMPSTATE_EXPECT3 of string * string * string * Mirage_crypto_pk.Dh.secret * string * string 70 | | SMPSTATE_EXPECT4 of string * string * string * Mirage_crypto_pk.Dh.secret 71 | 72 | let smp_state_to_string = function 73 | | SMPSTATE_WAIT_FOR_Y _ -> "waiting for secret" 74 | | SMPSTATE_EXPECT1 -> "initial" 75 | | SMPSTATE_EXPECT2 _ -> "waiting for msg 2" 76 | | SMPSTATE_EXPECT3 _ -> "waiting for msg 3" 77 | | SMPSTATE_EXPECT4 _ -> "waiting for msg 4" 78 | 79 | type policy = [ 80 | | `REQUIRE_ENCRYPTION 81 | | `SEND_WHITESPACE_TAG 82 | | `WHITESPACE_START_AKE 83 | | `ERROR_START_AKE 84 | | `REVEAL_MACS 85 | ] 86 | 87 | let policy_to_string = function 88 | | `REQUIRE_ENCRYPTION -> "require encryption" 89 | | `SEND_WHITESPACE_TAG -> "send whitespace tag" 90 | | `WHITESPACE_START_AKE -> "whitespace starts key exchange" 91 | | `ERROR_START_AKE -> "error starts key exchange" 92 | | `REVEAL_MACS -> "reveal mac keys" 93 | 94 | let string_to_policy = function 95 | | "REQUIRE_ENCRYPTION" -> Some `REQUIRE_ENCRYPTION 96 | | "SEND_WHITESPACE_TAG" -> Some `SEND_WHITESPACE_TAG 97 | | "WHITESPACE_START_AKE" -> Some `WHITESPACE_START_AKE 98 | | "ERROR_START_AKE" -> Some `ERROR_START_AKE 99 | | "REVEAL_MACS" -> Some `REVEAL_MACS 100 | | _ -> None 101 | 102 | let policy_of_sexp s = 103 | let atom = Sexplib0.Sexp_conv.string_of_sexp s in 104 | match string_to_policy atom with 105 | | None -> invalid_arg "bad sexp" 106 | | Some v -> v 107 | 108 | let sexp_of_policy p = 109 | let str = match p with 110 | | `REQUIRE_ENCRYPTION -> "REQUIRE_ENCRYPTION" 111 | | `SEND_WHITESPACE_TAG -> "SEND_WHITESPACE_TAG" 112 | | `WHITESPACE_START_AKE -> "WHITESPACE_START_AKE" 113 | | `ERROR_START_AKE -> "ERROR_START_AKE" 114 | | `REVEAL_MACS -> "REVEAL_MACS" 115 | in 116 | Sexplib0.Sexp_conv.sexp_of_string str 117 | 118 | let all_policies = [ `REQUIRE_ENCRYPTION ; `SEND_WHITESPACE_TAG ; `WHITESPACE_START_AKE ; `ERROR_START_AKE ; `REVEAL_MACS ] 119 | 120 | type version = [ `V2 | `V3 ] 121 | 122 | let version_to_string = function 123 | | `V2 -> "version 2" 124 | | `V3 -> "version 3" 125 | 126 | let string_to_version = function 127 | | "V2" -> Some `V2 128 | | "V3" -> Some `V3 129 | | _ -> None 130 | 131 | let version_of_sexp s = 132 | let v = Sexplib0.Sexp_conv.string_of_sexp s in 133 | match string_to_version v with 134 | | None -> invalid_arg "bad version" 135 | | Some x -> x 136 | 137 | let sexp_of_version v = 138 | let str = match v with 139 | | `V2 -> "V2" 140 | | `V3 -> "V3" 141 | in 142 | Sexplib0.Sexp_conv.sexp_of_string str 143 | 144 | let all_versions = [ `V2 ; `V3 ] 145 | 146 | type config = { 147 | policies : policy list ; 148 | versions : version list ; 149 | } 150 | 151 | let config_of_sexp = function 152 | | Sexplib0.Sexp.List fields_sexp -> 153 | let policies_field = ref None 154 | and versions_field = ref None 155 | in 156 | let rec iter = function 157 | | Sexplib0.Sexp.(List ((Atom field_name)::field::[]))::tail -> 158 | ((match field_name with 159 | | "policies" -> 160 | (match !policies_field with 161 | | None -> 162 | let fvalue = Sexplib0.Sexp_conv.list_of_sexp policy_of_sexp field in 163 | policies_field := Some fvalue 164 | | Some _ -> invalid_arg "duplicate field") 165 | | "versions" -> 166 | (match !versions_field with 167 | | None -> 168 | let fvalue = Sexplib0.Sexp_conv.list_of_sexp version_of_sexp field in 169 | versions_field := Some fvalue 170 | | Some _ -> invalid_arg "duplicate field") 171 | | _ -> invalid_arg "extra field") ; 172 | iter tail) 173 | | [] -> () 174 | | _ -> invalid_arg "bad sexp" 175 | in 176 | (iter fields_sexp; 177 | match !policies_field, !versions_field with 178 | | (Some policies_value, Some versions_value) -> 179 | { policies = policies_value; versions = versions_value } 180 | | _ -> invalid_arg "incomplete sexp") 181 | | _ -> invalid_arg "bad sexp" 182 | 183 | let sexp_of_config { policies = v_policies; versions = v_versions } = 184 | let bnds = [] in 185 | let bnds = 186 | let arg = Sexplib0.Sexp_conv.sexp_of_list sexp_of_version v_versions in 187 | Sexplib0.Sexp.(List [Atom "versions"; arg]) :: bnds in 188 | let bnds = 189 | let arg = Sexplib0.Sexp_conv.sexp_of_list sexp_of_policy v_policies in 190 | Sexplib0.Sexp.(List [Atom "policies"; arg]) :: bnds in 191 | Sexplib0.Sexp.List bnds 192 | 193 | type state = { 194 | message_state : message_state ; 195 | auth_state : auth_state ; 196 | smp_state : smp_state ; 197 | } 198 | 199 | type session = { 200 | instances : (int32 * int32) option ; 201 | version : version ; 202 | state : state ; 203 | config : config ; 204 | dsa : Mirage_crypto_pk.Dsa.priv ; 205 | fragments : ((int * int) * string) ; 206 | } 207 | 208 | let update_config config ctx = { ctx with config } 209 | 210 | let version x = x.version 211 | 212 | let reveal_macs session = 213 | List.mem `REVEAL_MACS session.config.policies 214 | 215 | let session_to_string s = 216 | let instances = match s.instances with 217 | | None -> "" 218 | | Some (x, y) -> 219 | Printf.sprintf ", instances: other %08lx, my %08lx" x y 220 | in 221 | let state = s.state in 222 | let version, auth_state, smp_state = 223 | let ver v = " " ^ version_to_string v in 224 | match state.message_state with 225 | | MSGSTATE_PLAINTEXT when state.auth_state = AUTHSTATE_NONE -> ("", " (auth none)", "") 226 | | MSGSTATE_PLAINTEXT -> (ver s.version, " (auth " ^ (auth_state_to_string state.auth_state) ^ ")", "") 227 | | MSGSTATE_ENCRYPTED _ -> (ver s.version, "", " (smp " ^ (smp_state_to_string state.smp_state) ^ ")") 228 | | MSGSTATE_FINISHED -> (ver s.version, "", "") 229 | in 230 | "state: " ^ (message_state_to_string s.state.message_state) ^ auth_state ^ 231 | version ^ smp_state ^ 232 | instances 233 | 234 | let new_session config dsa () = 235 | let state = { 236 | message_state = MSGSTATE_PLAINTEXT ; 237 | auth_state = AUTHSTATE_NONE ; 238 | smp_state = SMPSTATE_EXPECT1 239 | } 240 | and version = match config.versions with 241 | | [x] -> x 242 | | [] -> assert false 243 | | x when List.mem `V3 x -> `V3 244 | | _ -> `V2 245 | in 246 | { instances = None ; 247 | version ; 248 | state ; 249 | config ; 250 | dsa ; 251 | fragments = ((0, 0), "") 252 | } 253 | 254 | let config versions policies = 255 | if List.length versions = 0 then 256 | invalid_arg "no versions supplied" ; 257 | { versions ; policies } 258 | 259 | let rst_frag ctx = { ctx with fragments = ((0, 0), "") } 260 | 261 | let reset_session ctx = new_session ctx.config ctx.dsa () 262 | 263 | let is_encrypted ctx = 264 | match ctx.state.message_state with 265 | | MSGSTATE_ENCRYPTED _ -> true 266 | | _ -> false 267 | 268 | let their_dsa ctx = 269 | match ctx.state.message_state with 270 | | MSGSTATE_ENCRYPTED enc_data -> Some enc_data.their_dsa 271 | | _ -> None 272 | 273 | let tag_prefix = " \t \t\t\t\t \t \t \t " 274 | and tag_v2 = " \t\t \t " 275 | and tag_v3 = " \t\t \t\t" 276 | and otr_prefix = "?OTR" 277 | 278 | let otr_mark, otr_err_mark, otr_v2_frag, otr_v3_frag = 279 | (otr_prefix ^ ":", otr_prefix ^ " Error:", otr_prefix ^ ",", otr_prefix ^ "|") 280 | 281 | let (let*) = Result.bind 282 | 283 | let guard p e = if p then Ok () else Error e 284 | -------------------------------------------------------------------------------- /src/otr_state.mli: -------------------------------------------------------------------------------- 1 | type ret = [ 2 | | `Warning of string 3 | | `Received_error of string 4 | | `Received of string 5 | | `Established_encrypted_session of string 6 | | `Received_encrypted of string 7 | | `SMP_awaiting_secret 8 | | `SMP_received_question of string 9 | | `SMP_success 10 | | `SMP_failure 11 | ] 12 | 13 | type dh_params = (Mirage_crypto_pk.Dh.secret * string) 14 | 15 | type dh_keys = { 16 | dh : dh_params ; 17 | previous_dh : dh_params ; 18 | our_keyid : int32 ; 19 | gy : string ; 20 | previous_gy : string ; 21 | their_keyid : int32 ; 22 | } 23 | 24 | type symmetric_keys = { 25 | send_aes : string ; 26 | send_mac : string ; 27 | send_ctr : int64 ; 28 | recv_aes : string ; 29 | recv_mac : string ; 30 | recv_ctr : int64 ; 31 | } 32 | 33 | type symms = (int32 * int32 * symmetric_keys) list 34 | 35 | type enc_data = { 36 | dh_keys : dh_keys ; 37 | symms : symms ; 38 | their_dsa : Mirage_crypto_pk.Dsa.pub ; 39 | ssid : string ; 40 | high : bool ; 41 | } 42 | 43 | type message_state = 44 | | MSGSTATE_PLAINTEXT 45 | | MSGSTATE_ENCRYPTED of enc_data 46 | | MSGSTATE_FINISHED 47 | 48 | type auth_state = 49 | | AUTHSTATE_NONE 50 | | AUTHSTATE_AWAITING_DHKEY of string * string * dh_params * string 51 | | AUTHSTATE_AWAITING_REVEALSIG of dh_params * string 52 | | AUTHSTATE_AWAITING_SIG of string * (string * string * string * string) * dh_params * string 53 | 54 | type smp_state = 55 | | SMPSTATE_WAIT_FOR_Y of string * string 56 | | SMPSTATE_EXPECT1 57 | | SMPSTATE_EXPECT2 of string * Mirage_crypto_pk.Dh.secret * Mirage_crypto_pk.Dh.secret 58 | | SMPSTATE_EXPECT3 of string * string * string * Mirage_crypto_pk.Dh.secret * string * string 59 | | SMPSTATE_EXPECT4 of string * string * string * Mirage_crypto_pk.Dh.secret 60 | 61 | type policy = [ 62 | | `REQUIRE_ENCRYPTION 63 | | `SEND_WHITESPACE_TAG 64 | | `WHITESPACE_START_AKE 65 | | `ERROR_START_AKE 66 | | `REVEAL_MACS 67 | ] 68 | 69 | val sexp_of_policy : policy -> Sexplib0.Sexp.t 70 | val policy_of_sexp : Sexplib0.Sexp.t -> policy 71 | 72 | val policy_to_string : policy -> string 73 | 74 | val string_to_policy : string -> policy option 75 | 76 | val all_policies : policy list 77 | 78 | type version = [ `V2 | `V3 ] 79 | 80 | val sexp_of_version : version -> Sexplib0.Sexp.t 81 | val version_of_sexp : Sexplib0.Sexp.t -> version 82 | 83 | val version_to_string : version -> string 84 | 85 | val string_to_version : string -> version option 86 | 87 | val all_versions : version list 88 | 89 | type config = { 90 | policies : policy list ; 91 | versions : version list ; 92 | } 93 | 94 | val sexp_of_config : config -> Sexplib0.Sexp.t 95 | val config_of_sexp : Sexplib0.Sexp.t -> config 96 | 97 | val config : version list -> policy list -> config 98 | 99 | type state = { 100 | message_state : message_state ; 101 | auth_state : auth_state ; 102 | smp_state : smp_state ; 103 | } 104 | 105 | type session = { 106 | instances : (int32 * int32) option ; 107 | version : version ; 108 | state : state ; 109 | config : config ; 110 | dsa : Mirage_crypto_pk.Dsa.priv ; 111 | fragments : ((int * int) * string) ; 112 | } 113 | 114 | val rst_frag : session -> session 115 | 116 | val reset_session : session -> session 117 | 118 | val reveal_macs : session -> bool 119 | 120 | val session_to_string : session -> string 121 | 122 | val version : session -> version 123 | 124 | val is_encrypted : session -> bool 125 | 126 | val their_dsa : session -> Mirage_crypto_pk.Dsa.pub option 127 | 128 | val new_session : config -> Mirage_crypto_pk.Dsa.priv -> unit -> session 129 | 130 | val update_config : config -> session -> session 131 | 132 | val tag_prefix : string 133 | val tag_v2 : string 134 | val tag_v3 : string 135 | val otr_prefix : string 136 | val otr_mark : string 137 | val otr_err_mark : string 138 | val otr_v2_frag : string 139 | val otr_v3_frag : string 140 | 141 | val (let*) : ('a, 'e) result -> ('a -> ('b, 'e) result) -> ('b, 'e) result 142 | 143 | val guard : bool -> 'e -> (unit, 'e) result 144 | -------------------------------------------------------------------------------- /tests/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name feedback) 3 | (libraries otr mirage-crypto-pk)) 4 | -------------------------------------------------------------------------------- /tests/feedback.ml: -------------------------------------------------------------------------------- 1 | open Otr.State 2 | open Otr.Engine 3 | 4 | let teststring = "abcdedsajlkjdslkjflkjflkrjlkdlkadhkjncjknckj" 5 | 6 | let data () = 7 | let cnt = Random.int (pred (String.length teststring)) in 8 | String.sub teststring 0 (succ cnt) 9 | 10 | let send ctx = 11 | let str = data () in 12 | let ctx, out, user = send_otr ctx str in 13 | ( match user with 14 | | `Sent_encrypted x when x = str -> () 15 | | _ -> assert false ) ; 16 | let out = match out with None -> assert false | Some x -> x in 17 | (ctx, out, str) 18 | 19 | let recv ctx data str = 20 | let ctx, out, msgs = handle ctx data in 21 | assert (out = None); 22 | ( match msgs with 23 | | (`Received_encrypted x) :: [] when x = str -> () 24 | | _ -> assert false ) ; 25 | ctx 26 | 27 | let start_session _ = 28 | let keya = Mirage_crypto_pk.Dsa.generate `Fips1024 in 29 | let keyb = Mirage_crypto_pk.Dsa.generate `Fips1024 in 30 | let cfga = config all_versions all_policies in 31 | let cfgb = config all_versions all_policies in 32 | let ctxa = new_session cfga keya () in 33 | let ctxb = new_session cfgb keyb () in 34 | let ctxa, query = start_otr ctxa in 35 | let ctxb, out, msg = handle ctxb query in 36 | (* dh_commit *) 37 | assert (List.length msg = 0) ; 38 | (* ( match ctxb.state.auth_state with 39 | | AUTHSTATE_AWAITING_DHKEY _ -> () 40 | | _ -> assert false ); *) 41 | assert (not (is_encrypted ctxb)) ; 42 | let out = match out with None -> assert false | Some x -> x in 43 | let ctxa, out, msg = handle ctxa out in 44 | (* dh_key *) 45 | assert (List.length msg = 0) ; 46 | (* ( match ctxa.state.auth_state with 47 | | AUTHSTATE_AWAITING_REVEALSIG _ -> () 48 | | _ -> assert false ); *) 49 | assert (not (is_encrypted ctxa)) ; 50 | let out = match out with None -> assert false | Some x -> x in 51 | let ctxb, out, msg = handle ctxb out in 52 | (* reveal_sig *) 53 | assert (List.length msg = 0) ; 54 | (* ( match ctxb.state.auth_state with 55 | | AUTHSTATE_AWAITING_SIG _ -> () 56 | | _ -> assert false ); *) 57 | assert (not (is_encrypted ctxb)) ; 58 | let out = match out with None -> assert false | Some x -> x in 59 | let ctxa, out, msg = handle ctxa out in 60 | (* sig *) 61 | assert (List.length msg = 1) ; 62 | (* assert (ctxa.state.auth_state = AUTHSTATE_NONE) ; *) 63 | assert (is_encrypted ctxa) ; 64 | (*let ssida, higha = match ctxa.state.message_state with 65 | | MSGSTATE_ENCRYPTED enc_data -> enc_data.ssid, enc_data.high 66 | | _ -> assert false 67 | in *) 68 | let out = match out with None -> assert false | Some x -> x in 69 | let ctxb, _out, msg = handle ctxb out in 70 | (* finished *) 71 | assert (List.length msg = 1) ; 72 | (* assert (ctxb.state.auth_state = AUTHSTATE_NONE) ; *) 73 | assert (is_encrypted ctxb) ; 74 | (* let ssidb, highb = match ctxb.state.message_state with 75 | | MSGSTATE_ENCRYPTED enc_data -> enc_data.ssid, enc_data.high 76 | | _ -> assert false 77 | in 78 | assert (Cstruct.equal ssida ssidb) ; 79 | ( match higha, highb with 80 | | false, true -> () 81 | | true, false -> () 82 | | _ -> assert false ) ; *) 83 | let ctxa, out, str = send ctxa in 84 | let ctxb = recv ctxb out str in 85 | let ctxa, out, str = send ctxa in 86 | let ctxb = recv ctxb out str in 87 | let ctxa, out, str = send ctxa in 88 | let ctxb = recv ctxb out str in 89 | 90 | let ctxb, out, str = send ctxb in 91 | let ctxa = recv ctxa out str in 92 | let ctxa, out, str = send ctxa in 93 | let ctxb = recv ctxb out str in 94 | 95 | let ctxb, out, str = send ctxb in 96 | let ctxa = recv ctxa out str in 97 | let ctxa, out, str = send ctxa in 98 | let ctxb = recv ctxb out str in 99 | 100 | let ctxb, out, str = send ctxb in 101 | let ctxa = recv ctxa out str in 102 | let ctxa, out, str = send ctxa in 103 | let ctxb = recv ctxb out str in 104 | 105 | let ctxa, out, str = send ctxa in 106 | let ctxb = recv ctxb out str in 107 | let ctxa, out, str = send ctxa in 108 | let ctxb = recv ctxb out str in 109 | let ctxa, out, str = send ctxa in 110 | let ctxb = recv ctxb out str in 111 | 112 | let ctxb, out, str = send ctxb in 113 | let ctxa = recv ctxa out str in 114 | let ctxb, out, str = send ctxb in 115 | let ctxa = recv ctxa out str in 116 | let ctxb, out, str = send ctxb in 117 | let ctxa = recv ctxa out str in 118 | 119 | let ctxa, fin = end_otr ctxa in 120 | (* ( match ctxa.state.message_state with 121 | | MSGSTATE_PLAINTEXT -> () 122 | | _ -> assert false ) ; *) 123 | assert (not (is_encrypted ctxa)) ; 124 | let fin = match fin with None -> assert false | Some x -> x in 125 | let ctxb, out, msg = handle ctxb fin in 126 | assert (out = None) ; 127 | ( match msg with 128 | | (`Warning x)::[] -> assert (x = "OTR connection lost") 129 | | _ -> assert false ) ; 130 | assert (not (is_encrypted ctxb)) 131 | (* ( match ctxb.state.message_state with 132 | | MSGSTATE_FINISHED -> () 133 | | _ -> assert false ) *) 134 | 135 | let _ = 136 | let seed = Bytes.unsafe_to_string (Bytes.make 10 '\000') in 137 | let g = Mirage_crypto_rng.(create ~seed (module Fortuna)) in 138 | Mirage_crypto_rng.set_default_generator g; 139 | for _i = 0 to 1 do 140 | start_session () 141 | done 142 | --------------------------------------------------------------------------------