├── .gitignore ├── LICENCE ├── Makefile ├── README.md ├── _tags ├── breakbot.conf.example ├── lib ├── bitstamp_plugin.ml ├── btce.atd ├── btce.ml ├── btce_j.ml ├── btce_j.mli ├── btce_t.ml ├── btce_t.mli ├── common.ml ├── config.ml ├── ecb.ml ├── jsonrpc_utils.ml ├── lwt_utils.ml └── utils.ml ├── myocamlbuild.ml └── src ├── breakbot.ml └── cli.ml /.gitignore: -------------------------------------------------------------------------------- 1 | **/_build 2 | **/*.byte 3 | **/*.native 4 | -------------------------------------------------------------------------------- /LICENCE: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2012 Vincent Bernardoff 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | CC=ocamlbuild 2 | OPTS=-use-ocamlfind 3 | TARGETS=src/breakbot.ml src/cli.ml 4 | 5 | .PHONY: all native byte debug profiling cli.* breakbot.* clean 6 | 7 | all: native 8 | 9 | native: $(TARGETS:.ml=.native) 10 | byte: $(TARGETS:.ml=.byte) 11 | debug: $(TARGETS:.ml=.d.byte) 12 | profiling: $(TARGETS:.ml=.p.native) 13 | 14 | cli.[nbdp]*: 15 | $(CC) $(OPTS) $@ 16 | 17 | breakbot.[nbdp]*: 18 | $(CC) $(OPTS) $@ 19 | 20 | %.native %.byte %.d.byte %.p.native: %.ml 21 | $(CC) $(OPTS) $@ 22 | 23 | clean: 24 | $(CC) -clean 25 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Breakbot — An OCaml bot for arbitraging Bitcoin exchanges 2 | 3 | Breakbot is a bot able to take advantage of price discrepancies 4 | between several bitcoin exchanges. So far, support has been added for 5 | MtGox, Bitstamp, BTC-e and a limited support for Intersango has been 6 | added as well. 7 | 8 | I’m releasing this code because this is currently not possible 9 | (understand: profitable) to perform arbitrage between bitcoins 10 | exchanges. The main problem currently (2012-12-14) is that there is no 11 | way to automatically move funds (in currency equivalent, like USD) 12 | between exchanges (or the cumulative fees of buying/selling/moving 13 | money around would then be to high), and that the profit realized in 14 | performing arbitrage is currently too low to justify doing this 15 | activity manually. There is also no reason to believe it’s going to be 16 | so in a foreseeable future. 17 | 18 | ## Features 19 | 20 | * Exchange info is fed using the fastest possible way (websockets for 21 | MtGox, TCP socket for Intersango, HTTP polling for the other ones 22 | that do not support anything better). 23 | 24 | * CLI to interact with several bitcoin exchanges 25 | 26 | ## Dependencies 27 | 28 | * lwt 29 | * cohttp 30 | * cryptokit-sha512 31 | * ocaml-rpc 32 | * bitstring 33 | * jsonm 34 | * ocaml-websocket 35 | * uuidm 36 | * cmdliner 37 | * zarith 38 | 39 | I recommand you install these libraries using OPAM. 40 | 41 | ## Install 42 | 43 | Just type `make`. It will produce two executables, `cli.native` and 44 | `breakbot.native`. The CLI is a command-line interface to the 45 | supported bitcoin exchanges, and it allows to interact with your 46 | account in several ways (mainly display balance, place an order, 47 | withdraw bitcoins, display ticker, etc…). `breakbot.native` is the bot 48 | itself, currently all is he doing is to print out arbitrage 49 | opportunities each time an exchange is updated, that is, printing the 50 | amount of money to be moved from one exchange to another, and the 51 | resulting gain you can expect by doing so. Transaction fees for the 52 | exchanges are hardcoded, and are set to the current (2012-12-14) 53 | highest possible fees of a given exchange. It is thus an upper bound. 54 | 55 | ## Configuration 56 | 57 | Rename `breakbot.conf.example` into `breakbot.conf` and replace the 58 | template strings by actual values. The file follows the JSON syntax. 59 | 60 | ## Going further 61 | 62 | This is not a final product, I abandoned development when I realized 63 | that this project cannot be profitable for now. It was a cool project 64 | to develop, but as it misses its purpose, there is no much point doing 65 | anything more for it for now. Maybe the CLI could be useful for people 66 | that frequently interact with bitcoin exchanges, but it would require 67 | some polish to be really practical to use (and probably some testing 68 | as well :) 69 | -------------------------------------------------------------------------------- /_tags: -------------------------------------------------------------------------------- 1 | true: debug, bin_annot 2 | : include 3 | : include 4 | 5 | <**/*.{ml,mli,native,byte}>: syntax(camlp4o),\ 6 | package(optcomp),\ 7 | package(atdgen),\ 8 | package(lwt.syntax),\ 9 | package(lwt.syntax.log),\ 10 | package(rpclib.syntax),\ 11 | package(rpclib.json),\ 12 | package(jsonm),\ 13 | package(cohttp.lwt),\ 14 | package(cryptokit),\ 15 | package(websocket),\ 16 | package(uuidm),\ 17 | package(cmdliner),\ 18 | package(zarith),\ 19 | package(bitstamp),\ 20 | thread 21 | -------------------------------------------------------------------------------- /breakbot.conf.example: -------------------------------------------------------------------------------- 1 | { 2 | "mtgox": ["your-api-key-here", 3 | "your-api-key-secret-here", 4 | "your-mtgox-btc-address-here"], 5 | "intersango": ["your-api-key-here"], 6 | "btce": ["your-api-key-here", 7 | "your-api-secret-here", 8 | "your-btce-btc-address-here"], 9 | "bitstamp": ["your-account-number-here", 10 | "your-account-password-here", 11 | "your-bitstamp-btc-address-here"] 12 | } 13 | -------------------------------------------------------------------------------- /lib/bitstamp_plugin.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2012 Vincent Bernardoff 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | open Utils 19 | open Lwt_utils 20 | open Common 21 | 22 | module CU = Cohttp_lwt_unix 23 | module CB = Cohttp_lwt_body 24 | 25 | let period = 2.0 26 | 27 | let common_ticker_of_ticker t = 28 | let open Bitstamp_t in 29 | Ticker.make 30 | ~bid:(S.of_face_string t.ticker_bid) 31 | ~ask:(S.of_face_string t.ticker_ask) 32 | ~vol:(S.of_face_string t.ticker_volume) 33 | ~last:(S.of_face_string t.ticker_last) 34 | ~high:(S.of_face_string t.ticker_high) 35 | ~low:(S.of_face_string t.ticker_low) () 36 | 37 | class bitstamp userid key secret btc_addr push_f = 38 | object (self) 39 | inherit Exchange.exchange "bitstamp" push_f 40 | 41 | method fee = 0.005 42 | method currs = StringSet.of_list ["USD"] 43 | method base_curr = "USD" 44 | 45 | method update = 46 | lwt () = 47 | try_lwt 48 | Bitstamp.order_book () >>= function 49 | | `Error s -> Lwt.fail (Failure s) 50 | | `Ok ob -> 51 | let ask_book = List.fold_left 52 | (fun acc order -> match order with 53 | | [p;a] -> 54 | let price, amount = (S.of_face_string p), (S.of_face_string a) in 55 | Book.add price amount acc 56 | | _ -> raise (Invalid_argument "Corrupted bitstamp json or API changed.") 57 | ) Book.empty ob.Bitstamp_t.order_book_asks 58 | and bid_book = List.fold_left 59 | (fun acc order -> match order with 60 | | [p;a] -> 61 | let price, amount = (S.of_face_string p), (S.of_face_string a) in 62 | Book.add price amount acc 63 | | _ -> raise (Invalid_argument "Corrupted bitstamp json or API changed.") 64 | ) Book.empty ob.Bitstamp_t.order_book_bids in 65 | let () = books <- StringMap.add "USD" (bid_book, ask_book) books in 66 | Lwt.wrap (fun () -> self#notify) 67 | with exn -> 68 | Lwt_log.error_f ~exn "Bitstamp update error" 69 | finally Lwt_unix.sleep period 70 | in self#update 71 | 72 | method place_order kind curr price amount = 73 | if curr <> "USD" 74 | then Lwt.fail (Failure ("Unsupported currency: " ^ curr)) 75 | else 76 | let price = S.to_face_float price in 77 | let amount = S.to_face_float amount in 78 | (match kind with 79 | | Order.Bid -> Bitstamp.buy ~price ~amount 80 | | Order.Ask -> Bitstamp.sell ~price ~amount) 81 | >|= function 82 | | `Ok _ -> `Ok () 83 | | `Error s -> `Error s 84 | 85 | method withdraw_btc amount address = 86 | let amount = S.to_face_float amount in 87 | Bitstamp.bitcoin_withdrawal ~amount ~address >|= function 88 | | `Ok _ -> `Ok () 89 | | `Error s -> `Error s 90 | 91 | method get_btc_addr = btc_addr 92 | 93 | method get_balances = 94 | let open Bitstamp_t in 95 | Bitstamp.balance () >|= function 96 | | `Ok b -> 97 | `Ok ["USD", S.of_face_string b.balance_usd_available; 98 | "BTC", S.of_face_string b.balance_btc_available] 99 | | `Error s -> `Error s 100 | 101 | method get_ticker _ = 102 | Bitstamp.ticker () >|= function 103 | | `Ok ticker -> `Ok (common_ticker_of_ticker ticker) 104 | | `Error s -> `Error s 105 | 106 | method get_tickers = 107 | Lwt_list.map_p 108 | (fun c -> self#get_ticker c >>= fun t -> Lwt.return (c,t)) 109 | (StringSet.elements self#currs) 110 | end 111 | -------------------------------------------------------------------------------- /lib/btce.atd: -------------------------------------------------------------------------------- 1 | type order_book = { 2 | bids: float list list; 3 | asks: float list list; 4 | } 5 | -------------------------------------------------------------------------------- /lib/btce.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2012 Vincent Bernardoff 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | open Utils 19 | open Lwt_utils 20 | open Jsonrpc_utils 21 | open Common 22 | 23 | module CoUnix = Cohttp_lwt_unix 24 | module CK = Cryptokit 25 | 26 | let api_url = Uri.of_string "https://btc-e.com/tapi" 27 | let period = 2.0 28 | 29 | module Protocol = struct 30 | let btcecurr_of_curr = function 31 | | "EUR" -> "eur" 32 | | "USD" -> "usd" 33 | | "RUB" -> "rur" 34 | | _ -> failwith "btcecurr_of_curr" 35 | 36 | let make_get_url ?(obj="btc") curr kind = 37 | let btce_curr = btcecurr_of_curr curr in 38 | Uri.of_string @@ 39 | "https://btc-e.com/api/2/" ^ obj ^ "_" ^ btce_curr ^ "/" ^ kind 40 | 41 | type ticker_ = 42 | { 43 | high: float; 44 | low: float; 45 | avg: float; 46 | vol: float; 47 | vol_cur: float; 48 | last: float; 49 | buy: float; 50 | sell: float; 51 | server_time: float 52 | } with rpc 53 | 54 | type ticker = { ticker: ticker_ } with rpc 55 | 56 | let common_ticker_of_ticker t = 57 | Ticker.make 58 | ~ts:(Int64.of_float t.ticker.server_time) 59 | ~bid:(S.of_face_float t.ticker.sell) 60 | ~ask:(S.of_face_float t.ticker.buy) 61 | ~vol:(S.of_face_float t.ticker.vol_cur) 62 | ~last:(S.of_face_float t.ticker.last) 63 | ~high:(S.of_face_float t.ticker.high) 64 | ~low:(S.of_face_float t.ticker.low) () 65 | 66 | type funds = 67 | { 68 | usd: float; rur: float; eur: float; 69 | btc: float; ltc: float; nmc: float 70 | } with rpc 71 | 72 | type rights = 73 | { 74 | info: float; 75 | trade: float; 76 | withdraw: float 77 | } with rpc 78 | 79 | type getinfo = 80 | { 81 | funds: funds; 82 | rights: rights; 83 | transaction_count: float; 84 | open_orders: float; 85 | server_time: float 86 | } with rpc 87 | 88 | let query name params = 89 | let nonce = Unix.gettimeofday_str () in 90 | let params = ["method", name; "nonce", nonce] @ params in 91 | Uri.encoded_of_query @@ List.map (fun (k,v) -> k,[v]) params 92 | 93 | let parse_response rpc = let open Rpc in match rpc with 94 | | Dict ["success", Int 1L; "return", obj] -> Lwt.return obj 95 | | Dict ["success", Int 0L; "error", String err] -> raise_lwt (Failure err) 96 | | _ -> raise_lwt (Failure "should not happen") 97 | end 98 | 99 | class btce key secret btc_addr push_f = 100 | object (self) 101 | inherit Exchange.exchange "btce" push_f 102 | 103 | method fee = 0.002 104 | method currs = StringSet.of_list ["USD"] 105 | method base_curr = "USD" 106 | 107 | method update = 108 | let open Protocol in 109 | lwt () = 110 | try_lwt 111 | CU.Client.get (Protocol.make_get_url "USD" "depth") >>= function 112 | | None -> Lwt.fail (Failure "CU.Client.get returned None") 113 | | Some (response, body) -> 114 | CB.string_of_body body >>= fun body -> 115 | let open Btce_j in 116 | let order_book = order_book_of_string body in 117 | let ask_book = List.fold_left 118 | (fun acc order -> match order with 119 | | [p;a] -> 120 | let price, amount = (S.of_face_float p), (S.of_face_float a) in 121 | Book.add price amount acc 122 | | _ -> raise (Invalid_argument "Corrupted btce json or API changed.") 123 | ) Book.empty order_book.asks 124 | and bid_book = List.fold_left 125 | (fun acc order -> match order with 126 | | [p;a] -> 127 | let price, amount = (S.of_face_float p), (S.of_face_float a) in 128 | Book.add price amount acc 129 | | _ -> raise (Invalid_argument "Corrupted btce json or API changed.") 130 | ) Book.empty order_book.bids in 131 | let () = books <- StringMap.add "USD" (bid_book, ask_book) books in 132 | Lwt.wrap (fun () -> self#notify) 133 | with exn -> Lwt_log.error ~exn "Btce update error" 134 | finally Lwt_unix.sleep period 135 | in self#update 136 | 137 | 138 | method command query = 139 | let signed_query = 140 | CK.hash_string (CK.MAC.hmac_sha512 secret) query in 141 | let signed_query_hex = 142 | CK.transform_string (CK.Hexa.encode ()) signed_query in 143 | let headers = Cohttp.Header.of_list 144 | [ 145 | "User-Agent", "Breakbot"; 146 | "Content-Type", "application/x-www-form-urlencoded"; 147 | "Key", key; 148 | "Sign", signed_query_hex 149 | ] in 150 | lwt resp, body = Lwt.bind_opt @@ 151 | CU.Client.post ~chunked:false ~headers 152 | ?body:(CB.body_of_string query) api_url in 153 | CB.string_of_body body 154 | >|= Jsonrpc.of_string >>= Protocol.parse_response 155 | 156 | method place_order kind curr price amount = 157 | let pair = "btc_" ^ Protocol.btcecurr_of_curr curr in 158 | let kind = match kind with Order.Bid -> "buy" | Order.Ask -> "sell" in 159 | self#command @@ Protocol.query "Trade" 160 | [ 161 | "pair", pair; 162 | "type", kind; 163 | "rate", S.to_face_string price; 164 | "amount", S.to_face_string amount 165 | ] 166 | 167 | method withdraw_btc amount address = 168 | raise_lwt Failure "Not supported by the exchange" 169 | 170 | method get_btc_addr = btc_addr 171 | 172 | method get_balances = 173 | let open Protocol in 174 | lwt rpc = self#command @@ query "getInfo" [] in 175 | let rpc_float = Rpc.int_to_float rpc in 176 | let getinfo = getinfo_of_rpc rpc_float in 177 | Lwt.return 178 | ["EUR", S.of_face_float getinfo.funds.eur; 179 | "USD", S.of_face_float getinfo.funds.usd; 180 | "RUB", S.of_face_float getinfo.funds.rur; 181 | "BTC", S.of_face_float getinfo.funds.btc] 182 | 183 | method get_ticker curr = 184 | lwt rpc = (Lwt.wrap2 Protocol.make_get_url curr "ticker") 185 | >>= Jsonrpc.get_int_to_float in 186 | Lwt.wrap (fun () -> 187 | Protocol.common_ticker_of_ticker @@ Protocol.ticker_of_rpc rpc) 188 | 189 | method get_tickers = 190 | Lwt_list.map_p 191 | (fun c -> lwt t = self#get_ticker c in Lwt.return (c,t)) 192 | (StringSet.elements self#currs) 193 | end 194 | -------------------------------------------------------------------------------- /lib/btce_j.ml: -------------------------------------------------------------------------------- 1 | (* Auto-generated from "btce.atd" *) 2 | 3 | 4 | type order_book = Btce_t.order_book = { 5 | bids: float list list; 6 | asks: float list list 7 | } 8 | 9 | let write__1 = ( 10 | Ag_oj_run.write_list ( 11 | Yojson.Safe.write_float 12 | ) 13 | ) 14 | let string_of__1 ?(len = 1024) x = 15 | let ob = Bi_outbuf.create len in 16 | write__1 ob x; 17 | Bi_outbuf.contents ob 18 | let read__1 = ( 19 | Ag_oj_run.read_list ( 20 | Ag_oj_run.read_number 21 | ) 22 | ) 23 | let _1_of_string s = 24 | read__1 (Yojson.Safe.init_lexer ()) (Lexing.from_string s) 25 | let write__2 = ( 26 | Ag_oj_run.write_list ( 27 | write__1 28 | ) 29 | ) 30 | let string_of__2 ?(len = 1024) x = 31 | let ob = Bi_outbuf.create len in 32 | write__2 ob x; 33 | Bi_outbuf.contents ob 34 | let read__2 = ( 35 | Ag_oj_run.read_list ( 36 | read__1 37 | ) 38 | ) 39 | let _2_of_string s = 40 | read__2 (Yojson.Safe.init_lexer ()) (Lexing.from_string s) 41 | let write_order_book = ( 42 | fun ob x -> 43 | Bi_outbuf.add_char ob '{'; 44 | let is_first = ref true in 45 | if !is_first then 46 | is_first := false 47 | else 48 | Bi_outbuf.add_char ob ','; 49 | Bi_outbuf.add_string ob "\"bids\":"; 50 | ( 51 | write__2 52 | ) 53 | ob x.bids; 54 | if !is_first then 55 | is_first := false 56 | else 57 | Bi_outbuf.add_char ob ','; 58 | Bi_outbuf.add_string ob "\"asks\":"; 59 | ( 60 | write__2 61 | ) 62 | ob x.asks; 63 | Bi_outbuf.add_char ob '}'; 64 | ) 65 | let string_of_order_book ?(len = 1024) x = 66 | let ob = Bi_outbuf.create len in 67 | write_order_book ob x; 68 | Bi_outbuf.contents ob 69 | let read_order_book = ( 70 | fun p lb -> 71 | Yojson.Safe.read_space p lb; 72 | Yojson.Safe.read_lcurl p lb; 73 | let x = 74 | { 75 | bids = Obj.magic 0.0; 76 | asks = Obj.magic 0.0; 77 | } 78 | in 79 | let bits0 = ref 0 in 80 | try 81 | Yojson.Safe.read_space p lb; 82 | Yojson.Safe.read_object_end lb; 83 | Yojson.Safe.read_space p lb; 84 | let f = 85 | fun s pos len -> 86 | if pos < 0 || len < 0 || pos + len > String.length s then 87 | invalid_arg "out-of-bounds substring position or length"; 88 | if len = 4 then ( 89 | match String.unsafe_get s pos with 90 | | 'a' -> ( 91 | if String.unsafe_get s (pos+1) = 's' && String.unsafe_get s (pos+2) = 'k' && String.unsafe_get s (pos+3) = 's' then ( 92 | 1 93 | ) 94 | else ( 95 | -1 96 | ) 97 | ) 98 | | 'b' -> ( 99 | if String.unsafe_get s (pos+1) = 'i' && String.unsafe_get s (pos+2) = 'd' && String.unsafe_get s (pos+3) = 's' then ( 100 | 0 101 | ) 102 | else ( 103 | -1 104 | ) 105 | ) 106 | | _ -> ( 107 | -1 108 | ) 109 | ) 110 | else ( 111 | -1 112 | ) 113 | in 114 | let i = Yojson.Safe.map_ident p f lb in 115 | Ag_oj_run.read_until_field_value p lb; 116 | ( 117 | match i with 118 | | 0 -> 119 | let v = 120 | ( 121 | read__2 122 | ) p lb 123 | in 124 | Obj.set_field (Obj.repr x) 0 (Obj.repr v); 125 | bits0 := !bits0 lor 0x1; 126 | | 1 -> 127 | let v = 128 | ( 129 | read__2 130 | ) p lb 131 | in 132 | Obj.set_field (Obj.repr x) 1 (Obj.repr v); 133 | bits0 := !bits0 lor 0x2; 134 | | _ -> ( 135 | Yojson.Safe.skip_json p lb 136 | ) 137 | ); 138 | while true do 139 | Yojson.Safe.read_space p lb; 140 | Yojson.Safe.read_object_sep p lb; 141 | Yojson.Safe.read_space p lb; 142 | let f = 143 | fun s pos len -> 144 | if pos < 0 || len < 0 || pos + len > String.length s then 145 | invalid_arg "out-of-bounds substring position or length"; 146 | if len = 4 then ( 147 | match String.unsafe_get s pos with 148 | | 'a' -> ( 149 | if String.unsafe_get s (pos+1) = 's' && String.unsafe_get s (pos+2) = 'k' && String.unsafe_get s (pos+3) = 's' then ( 150 | 1 151 | ) 152 | else ( 153 | -1 154 | ) 155 | ) 156 | | 'b' -> ( 157 | if String.unsafe_get s (pos+1) = 'i' && String.unsafe_get s (pos+2) = 'd' && String.unsafe_get s (pos+3) = 's' then ( 158 | 0 159 | ) 160 | else ( 161 | -1 162 | ) 163 | ) 164 | | _ -> ( 165 | -1 166 | ) 167 | ) 168 | else ( 169 | -1 170 | ) 171 | in 172 | let i = Yojson.Safe.map_ident p f lb in 173 | Ag_oj_run.read_until_field_value p lb; 174 | ( 175 | match i with 176 | | 0 -> 177 | let v = 178 | ( 179 | read__2 180 | ) p lb 181 | in 182 | Obj.set_field (Obj.repr x) 0 (Obj.repr v); 183 | bits0 := !bits0 lor 0x1; 184 | | 1 -> 185 | let v = 186 | ( 187 | read__2 188 | ) p lb 189 | in 190 | Obj.set_field (Obj.repr x) 1 (Obj.repr v); 191 | bits0 := !bits0 lor 0x2; 192 | | _ -> ( 193 | Yojson.Safe.skip_json p lb 194 | ) 195 | ); 196 | done; 197 | assert false; 198 | with Yojson.End_of_object -> ( 199 | if !bits0 <> 0x3 then Ag_oj_run.missing_fields [| !bits0 |] [| "bids"; "asks" |]; 200 | Ag_oj_run.identity x 201 | ) 202 | ) 203 | let order_book_of_string s = 204 | read_order_book (Yojson.Safe.init_lexer ()) (Lexing.from_string s) 205 | -------------------------------------------------------------------------------- /lib/btce_j.mli: -------------------------------------------------------------------------------- 1 | (* Auto-generated from "btce.atd" *) 2 | 3 | 4 | type order_book = Btce_t.order_book = { 5 | bids: float list list; 6 | asks: float list list 7 | } 8 | 9 | val write_order_book : 10 | Bi_outbuf.t -> order_book -> unit 11 | (** Output a JSON value of type {!order_book}. *) 12 | 13 | val string_of_order_book : 14 | ?len:int -> order_book -> string 15 | (** Serialize a value of type {!order_book} 16 | into a JSON string. 17 | @param len specifies the initial length 18 | of the buffer used internally. 19 | Default: 1024. *) 20 | 21 | val read_order_book : 22 | Yojson.Safe.lexer_state -> Lexing.lexbuf -> order_book 23 | (** Input JSON data of type {!order_book}. *) 24 | 25 | val order_book_of_string : 26 | string -> order_book 27 | (** Deserialize JSON data of type {!order_book}. *) 28 | 29 | -------------------------------------------------------------------------------- /lib/btce_t.ml: -------------------------------------------------------------------------------- 1 | (* Auto-generated from "btce.atd" *) 2 | 3 | 4 | type order_book = { bids: float list list; asks: float list list } 5 | -------------------------------------------------------------------------------- /lib/btce_t.mli: -------------------------------------------------------------------------------- 1 | (* Auto-generated from "btce.atd" *) 2 | 3 | 4 | type order_book = { bids: float list list; asks: float list list } 5 | -------------------------------------------------------------------------------- /lib/common.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2012 Vincent Bernardoff 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | open Utils 19 | 20 | module Cent = functor (R : (sig val value: float end)) -> struct 21 | include Z 22 | 23 | let rpc_of_t v = Rpc.String (to_bits v) 24 | let t_of_rpc = function 25 | | Rpc.String v -> of_bits v 26 | | _ -> failwith "Cent.t_of_rpc" 27 | let of_face_float v = of_float (v *. R.value) 28 | let to_face_float v = to_float v /. R.value 29 | let of_face_string v = of_float (float_of_string v *. R.value) 30 | let to_face_string v = string_of_float (to_face_float v) 31 | end 32 | 33 | module S = struct 34 | include Cent (struct let value = 1e8 end) 35 | 36 | let of_dollar_string v = of_string v * ~$1000 37 | end 38 | 39 | module SMap = Map.Make(S) 40 | 41 | module Order = struct 42 | type kind = Bid | Ask 43 | 44 | let kind_of_string str = 45 | let caseless = String.lowercase str in 46 | match caseless with 47 | | "bid" | "bids" -> Bid 48 | | "ask" | "asks" -> Ask 49 | | _ -> failwith "Order.kind_of_string" 50 | 51 | let string_of_kind = function Bid -> "bid" | Ask -> "ask" 52 | 53 | type strategy = 54 | | Market (* non-limit order *) 55 | | Limit (* Good till canceled -- classic limit order *) 56 | | Limit_IOC 57 | (* Immediate or cancel : at least partially executed or immediately 58 | cancelled *) 59 | | Limit_FOK (* Fill or kill : fully executed or immediately canceled *) 60 | 61 | type order = 62 | { 63 | exchange: string; 64 | kind: kind; 65 | currency: string; 66 | price: S.t; 67 | amount: S.t 68 | } 69 | 70 | (** When an exchange fails to send an order *) 71 | exception Failure of order * string 72 | end 73 | 74 | module Ticker = struct 75 | type t = 76 | { ts: int64; 77 | bid: S.t; 78 | ask: S.t; 79 | last: S.t; 80 | vol: S.t; 81 | high: S.t; 82 | low: S.t } 83 | 84 | let make ?(ts=Unix.getmicrotime_int64 ()) 85 | ?(high=Z.minus_one) 86 | ?(low=Z.minus_one) 87 | ?(vol=Z.minus_one) 88 | ~bid ~ask ~last () = 89 | { ts; bid; ask; last; vol; high; low } 90 | end 91 | 92 | module type BOOK = sig 93 | include Map.S with type key = S.t 94 | 95 | type bindings = (S.t * S.t) list 96 | 97 | val rpc_of_t : S.t t -> Rpc.t 98 | val t_of_rpc : Rpc.t -> S.t t 99 | 100 | val update : S.t -> S.t -> S.t t -> S.t t 101 | val arbiter : S.t t -> S.t t -> int -> float -> S.t * S.t * S.t * S.t 102 | end 103 | 104 | (** A book represent the depth for one currency, and one order kind *) 105 | module Book : BOOK = struct 106 | include SMap 107 | 108 | type bindings = (S.t * S.t) list with rpc 109 | 110 | let rpc_of_t v = rpc_of_bindings (bindings v) 111 | let t_of_rpc rpc = of_bindings (bindings_of_rpc rpc) 112 | 113 | let update price amount book = 114 | try 115 | let old_amount = SMap.find price book in 116 | SMap.add price S.(old_amount + amount) book 117 | with Not_found -> SMap.add price amount book 118 | 119 | let depth_of_ask askbook = 120 | let open S in 121 | let _,_,newbook = 122 | SMap.fold (fun pr am (depth, price, acc) -> 123 | let ndepth = depth + am 124 | and nprice = price + pr*am in 125 | (ndepth, nprice, SMap.add pr (ndepth, nprice) acc) 126 | ) askbook (~$0, ~$0, SMap.empty) 127 | in newbook 128 | 129 | let depth_of_bid bidbook = 130 | let open S in 131 | let bindings = SMap.bindings bidbook in 132 | let _,_,newbook = 133 | List.fold_right (fun (pr, am) (depth, price, acc) -> 134 | let ndepth = depth + am 135 | and nprice = price + pr*am in 136 | (ndepth, nprice, SMap.add pr (ndepth, nprice) acc) 137 | ) bindings (~$0, ~$0, SMap.empty) 138 | in newbook 139 | 140 | let amount_at_price_ask askdepthbook price = 141 | let open S in 142 | SMap.fold (fun pr (depth, prr) acc -> 143 | if pr < price then depth else acc) askdepthbook ~$0 144 | 145 | let buy_price book qty = 146 | let open S in 147 | SMap.fold (fun pr am (qty_rem, price) -> 148 | let min_qty = min am qty_rem in 149 | (qty_rem - min_qty, price + pr*min_qty) 150 | ) book (qty, ~$0) 151 | 152 | let sell_price book qty = 153 | let open S in 154 | let bindings = SMap.bindings book in 155 | List.fold_right (fun (pr, am) (qty_rem, price) -> 156 | let min_qty = min am qty_rem in 157 | (qty_rem - min_qty, price + pr*min_qty) 158 | ) bindings (qty, ~$0) 159 | 160 | 161 | let arbiter bid ask num_iter min_ratio = 162 | let open S in 163 | let max_bid = fst @@ max_binding bid 164 | and min_ask = fst @@ min_binding ask in 165 | if gt max_bid min_ask then 166 | let askdepthbook = depth_of_ask ask in 167 | let max_qty = amount_at_price_ask askdepthbook max_bid in 168 | let interval = max_qty / (of_int num_iter) in 169 | let rec perform acc i = 170 | if i <= num_iter then 171 | let qty = (of_int i) * interval in 172 | let sell_qty_rem, sell_pr = sell_price bid qty 173 | and buy_qty_rem, buy_pr = buy_price ask qty in 174 | let gain = sell_pr - buy_pr in 175 | if max sell_qty_rem buy_qty_rem <> ~$0 then acc 176 | else 177 | (Lwt.ignore_result @@ 178 | Lwt_log.debug_f "%f, %f, %f, %f\n%!" 179 | (S.to_face_float qty) 180 | (S.to_float sell_pr /. 1e16) 181 | (S.to_float buy_pr /. 1e16) 182 | (S.to_float gain /. 1e16); 183 | perform 184 | (if (to_float gain /. to_float buy_pr) > min_ratio 185 | then Pervasives.max acc (gain, -qty, sell_pr, buy_pr) 186 | else acc) 187 | (Pervasives.succ i)) 188 | else acc in 189 | let res, time = Utils.timeit 190 | (fun () -> perform (~$0, ~$0, ~$0, ~$0) 1) in 191 | Lwt.ignore_result @@ 192 | Lwt_log.info_f ("Computation time: %0.6f\n") time; 193 | res 194 | else 195 | (~$0, ~$0, ~$0, ~$0) 196 | end 197 | 198 | module MakeBooks (B : BOOK) = struct 199 | type book = S.t B.t 200 | let book_of_rpc = B.t_of_rpc 201 | let rpc_of_book = B.rpc_of_t 202 | 203 | type t = (book * book) StringMap.t 204 | type bindings = (string * (book * book)) list with rpc 205 | 206 | let rpc_of_t v = rpc_of_bindings (StringMap.bindings v) 207 | let t_of_rpc rpc = StringMap.of_bindings (bindings_of_rpc rpc) 208 | 209 | let (empty:t) = StringMap.empty 210 | 211 | let modify 212 | (action_fun : B.key -> B.key -> S.t B.t -> S.t B.t) 213 | books curr kind price amount = 214 | let bid, ask = 215 | try StringMap.find curr books 216 | with Not_found -> (B.empty, B.empty) in 217 | match kind with 218 | | Order.Bid -> 219 | let newbook = action_fun price amount bid in 220 | StringMap.add curr (newbook, ask) books 221 | | Order.Ask -> 222 | let newbook = action_fun price amount ask in 223 | StringMap.add curr (bid, newbook) books 224 | 225 | let add = modify B.add 226 | let update = modify B.update 227 | 228 | let remove books curr = StringMap.remove curr books 229 | 230 | let arbiter_unsafe curr books1 books2 nb_iter min_ratio = 231 | let open S in 232 | let b1, a1 = StringMap.find curr books1 233 | and b2, a2 = StringMap.find curr books2 in 234 | let gain1, qty1, spr1, bpr1 = (B.arbiter b2 a1 nb_iter min_ratio) 235 | and gain2, qty2, spr2, bpr2 = (B.arbiter b1 a2 nb_iter min_ratio) in 236 | (gain1 <> ~$0), 237 | Pervasives.max 238 | (gain1, -qty1, spr1, bpr1) (gain2, -qty2, spr2, bpr2) 239 | 240 | let print books = 241 | let print_one book = Book.iter 242 | (fun price amount -> Printf.printf "(%f,%f) " 243 | (S.to_face_float price) 244 | (S.to_face_float amount)) book in 245 | StringMap.iter (fun curr (bid,ask) -> 246 | Printf.printf "BID %s\n" curr; 247 | print_one bid; print_endline ""; 248 | Printf.printf "ASK %s\n" curr; 249 | print_one ask; print_endline "" 250 | ) books 251 | end 252 | 253 | module Books = MakeBooks(Book) 254 | 255 | type 'a ok_or_error = [`Ok of 'a | `Error of string] 256 | 257 | module Exchange = struct 258 | type balances = (string * S.t) list 259 | 260 | class virtual exchange (name:string) (push_f: 'a option -> unit) = 261 | object (self) 262 | val mutable books = Books.empty 263 | 264 | method name = name 265 | method get_books = books 266 | method print = Printf.printf "Books for exchange %s:\n%!" name; 267 | Books.print books 268 | method notify = push_f (Some self#name) 269 | 270 | method virtual fee : float 271 | method virtual currs : StringSet.t 272 | method virtual base_curr : string 273 | 274 | method virtual update : unit Lwt.t 275 | method virtual place_order : Order.kind -> string -> S.t -> S.t -> (unit ok_or_error) Lwt.t 276 | method virtual withdraw_btc : S.t -> string -> (unit ok_or_error) Lwt.t 277 | method virtual get_btc_addr : string 278 | method virtual get_balances : (balances ok_or_error) Lwt.t 279 | method virtual get_tickers : (string * Ticker.t ok_or_error) list Lwt.t 280 | end 281 | end 282 | -------------------------------------------------------------------------------- /lib/config.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2012 Vincent Bernardoff 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | (** Access configuration file *) 19 | open Utils 20 | 21 | type config = (string * (string list)) list with rpc 22 | 23 | let of_file fname = 24 | let str = String.of_file fname in 25 | config_of_rpc @@ Jsonrpc.of_string str 26 | -------------------------------------------------------------------------------- /lib/ecb.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2012 Vincent Bernardoff 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | (** Get the latest ECB rates *) 19 | 20 | open Utils 21 | open Lwt_utils 22 | 23 | open Cohttp_lwt_unix 24 | 25 | let url = "http://www.ecb.europa.eu/stats/eurofxref/eurofxref-daily.xml" 26 | 27 | let get_rates ?(url=url) () = 28 | let uri = Uri.of_string url in 29 | lwt resp, body = Lwt.bind_opt $ Client.get uri in 30 | lwt xml = Body.string_of_body body in 31 | lwt xml_input = Lwt.wrap1 Xmlm.make_input (`String (0, xml)) in 32 | let rec parse acc input = 33 | let next = try Some (Xmlm.input input) with _ -> None in 34 | if next = None then acc else 35 | match Opt.unbox next with 36 | | `El_start ((_, "Cube"), 37 | [((_, "currency"), curr); ((_, "rate"), rate)]) -> 38 | parse ((curr, float_of_string rate)::acc) input 39 | | _ -> parse acc input 40 | in 41 | Lwt.wrap2 parse [] xml_input 42 | 43 | let get_rates_curr ?(url=url) curr = 44 | lwt rates = get_rates ~url () in 45 | if curr = "EUR" then Lwt.return (("EUR", 1.)::rates) else 46 | let curr_rate = List.assoc curr rates in 47 | Lwt.return 48 | (("EUR", 1. /. curr_rate) :: 49 | List.map (fun (s,r) -> s, (r /. curr_rate)) rates) 50 | 51 | let make_convert rates from = 52 | fun curr -> 53 | (let rate = List.assoc curr rates in 54 | (fun amount -> rate *. amount)) 55 | 56 | let make_convert_Z rates from = 57 | fun curr -> 58 | (let rate = List.assoc curr rates in 59 | fun amount -> Z.of_float (rate *. Z.to_float amount)) 60 | 61 | let converters = 62 | lwt rates = get_rates_curr "USD" in 63 | let currencies = List.map (fun (c,_) -> c) rates in 64 | let convert_froms = List.map 65 | (fun c -> c, make_convert_Z rates c) currencies in 66 | let converters_funs = 67 | List.map (fun (c, f) -> List.map 68 | (fun curr -> ((c, curr), (f curr))) 69 | currencies) convert_froms |> List.flatten in 70 | Lwt.return (fun from to_ -> List.assoc (from, to_) converters_funs) 71 | -------------------------------------------------------------------------------- /lib/jsonrpc_utils.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2012 Vincent Bernardoff 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | open Utils 19 | open Lwt_utils 20 | module CU = Cohttp_lwt_unix 21 | module CB = Cohttp_lwt_body 22 | 23 | module Rpc = struct 24 | include Rpc 25 | 26 | let rec filter_null = function 27 | | Enum l -> Enum (List.map filter_null l) 28 | | Dict d -> Dict ( 29 | List.map (fun (s,v) -> s, filter_null v) @@ 30 | List.filter (fun (s,v) -> v <> Null) d) 31 | | oth -> oth 32 | 33 | let rec int_to_float = function 34 | | Enum l -> Enum (List.map int_to_float l) 35 | | Dict d -> Dict (List.map (fun (s,v) -> s, int_to_float v) d) 36 | | Int i -> Float (Int64.to_float i) 37 | | oth -> oth 38 | end 39 | 40 | module Jsonrpc = struct 41 | include Jsonrpc 42 | 43 | let get ?(transform=fun i -> i) url = 44 | lwt resp, body = Lwt.bind_opt @@ CU.Client.get url in 45 | lwt body_str = CB.string_of_body body in 46 | let rpc = of_string body_str in Lwt.wrap (fun () -> transform rpc) 47 | 48 | let get_filter_null = get ~transform:Rpc.filter_null 49 | let get_int_to_float = get ~transform:Rpc.int_to_float 50 | 51 | end 52 | -------------------------------------------------------------------------------- /lib/lwt_utils.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2012 Vincent Bernardoff 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | let (>>=) = Lwt.bind 19 | let (=<<) f g = Lwt.bind g f 20 | let (>|=) f g = Lwt.map g f 21 | let (=|<) f g = Lwt.map f g 22 | 23 | module Lwt = struct 24 | include Lwt 25 | 26 | let wrapopt = function 27 | | Some v -> return v 28 | | None -> raise_lwt Not_found 29 | 30 | let bind_opt m = 31 | bind m (function Some v -> return v | None -> raise_lwt Not_found) 32 | end 33 | 34 | module Lwt_io = struct 35 | include Lwt_io 36 | open Lwt_unix 37 | 38 | let sockaddr_of_dns 39 | ?(gaiopts = [AI_FAMILY(PF_INET); AI_SOCKTYPE(SOCK_STREAM)]) 40 | node service = 41 | (match_lwt getaddrinfo node service gaiopts with 42 | | h::t -> Lwt.return h 43 | | [] -> raise_lwt Not_found) 44 | >|= fun ai -> ai.ai_addr 45 | end 46 | -------------------------------------------------------------------------------- /lib/utils.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2012 Vincent Bernardoff 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | #if ocaml_version < (4, 1) 19 | let (@@) f x = f x 20 | let (|>) x f = f x 21 | #endif 22 | 23 | let (++) f g x = f (g x) 24 | let (|) = (lor) 25 | let (&) = (land) 26 | 27 | module Opt = struct 28 | let unbox = function 29 | | Some v -> v 30 | | None -> raise Not_found 31 | 32 | let default d = function 33 | | Some v -> v 34 | | None -> d 35 | 36 | let map f = function 37 | | Some v -> Some (f v) 38 | | None -> None 39 | end 40 | 41 | module Int32 = struct 42 | include Int32 43 | 44 | (** Adding convenient operators like in Z *) 45 | let (+) = add 46 | let (-) = sub 47 | let ( * ) = mul 48 | let (/) = div 49 | let (lsr) = shift_right_logical 50 | let (lsl) = shift_left 51 | let (|) = logor 52 | let (&) = logand 53 | end 54 | 55 | module Int64 = struct 56 | include Int64 57 | 58 | (** Adding convenient operators like in Z *) 59 | let (+) = add 60 | let (-) = sub 61 | let ( * ) = mul 62 | let (/) = div 63 | let (lsr) = shift_right_logical 64 | let (lsl) = shift_left 65 | let (|) = logor 66 | let (&) = logand 67 | end 68 | 69 | let i_int i = fun (i:int) -> () 70 | let i_float i = fun (i:float) -> () 71 | let i_string i = fun (i:string) -> () 72 | 73 | module Map = struct 74 | module type OrderedType = sig 75 | include Map.OrderedType 76 | end 77 | 78 | module type S = sig 79 | include Map.S 80 | 81 | val of_bindings : (key * 'a) list -> 'a t 82 | end 83 | 84 | module Make(Ord: OrderedType) = struct 85 | include Map.Make(Ord) 86 | 87 | let of_bindings assocs = 88 | List.fold_left (fun acc (k,v) -> add k v acc) empty assocs 89 | end 90 | end 91 | 92 | module Set = struct 93 | module type OrderedType = sig 94 | include Set.OrderedType 95 | end 96 | 97 | module type S = sig 98 | include Set.S 99 | 100 | val of_list : elt list -> t 101 | end 102 | 103 | module Make(Ord: OrderedType) = struct 104 | include Set.Make(Ord) 105 | 106 | let of_list l = 107 | List.fold_left (fun acc v -> add v acc) empty l 108 | end 109 | end 110 | 111 | module IntMap = Map.Make 112 | (struct 113 | type t = int 114 | let compare = Pervasives.compare 115 | end) 116 | module Int64Map = Map.Make(Int64) 117 | module StringMap = Map.Make(String) 118 | module StringSet = Set.Make(String) 119 | 120 | (* "finally" is a lwt keyword... *) 121 | let with_finally f f_block = 122 | try 123 | let res = f () in f_block (); res 124 | with e -> 125 | f_block (); raise e 126 | 127 | let timeit f = 128 | let time_start = Unix.gettimeofday () in 129 | let ret = f () in 130 | ret, (Unix.gettimeofday () -. time_start) 131 | 132 | module Unix = struct 133 | include Unix 134 | 135 | let gettimeofday_int () = int_of_float @@ gettimeofday () 136 | let gettimeofday_str () = Printf.sprintf "%.0f" @@ gettimeofday () 137 | 138 | let getmicrotime () = gettimeofday () *. 1e6 139 | let getmicrotime_int64 () = Int64.of_float @@ gettimeofday () *. 1e6 140 | let getmicrotime_str () = Printf.sprintf "%.0f" @@ gettimeofday () *. 1e6 141 | end 142 | 143 | module String = struct 144 | include String 145 | 146 | let is_int str = 147 | try let (_:int) = int_of_string str in true with _ -> false 148 | 149 | let is_float str = 150 | try let (_:float) = float_of_string str in true with _ -> false 151 | 152 | let of_file fname = 153 | let ic = open_in fname in 154 | let ic_len = in_channel_length ic in 155 | let buf = String.create ic_len in 156 | let rec input_forever len pos = 157 | if len = 0 then buf 158 | else let read = input ic buf pos len 159 | in input_forever (len-read) (pos+read) in 160 | with_finally 161 | (fun () -> input_forever ic_len 0) 162 | (fun () -> close_in ic) 163 | end 164 | -------------------------------------------------------------------------------- /myocamlbuild.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2012 Vincent Bernardoff 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | open Ocamlbuild_plugin 19 | 20 | let () = dispatch begin function 21 | | After_rules -> flag ["ocaml"; "compile"; "debug"] & S[A"-ppopt"; A"-lwt-debug"] 22 | | _ -> () 23 | end 24 | -------------------------------------------------------------------------------- /src/breakbot.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2012 Vincent Bernardoff 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | open Utils 19 | open Lwt_utils 20 | open Common 21 | 22 | (* Works only if processing is much faster than the rate at which we 23 | receive/parse the messages from the exchange. Otherwise processing 24 | might block the exchanges from updating... It has thus to be the 25 | case that processing is indeed faster than receiving+parsing *) 26 | 27 | let nb_of_iter = 100 28 | let min_ratio = 0.0 29 | 30 | let main () = 31 | let template = "$(date).$(milliseconds) [$(level)]: $(message)" in 32 | let std_logger = 33 | Lwt_log.channel ~template ~close_mode:`Keep ~channel:Lwt_io.stdout () in 34 | lwt file_logger = Lwt_log.file ~template ~file_name:"breakbot.log" () in 35 | let brd_logger = Lwt_log.broadcast [std_logger; file_logger] in 36 | let () = Lwt_log.default := brd_logger in 37 | let config = Config.of_file "breakbot.conf" in 38 | let mtgox_key, mtgox_secret, mtgox_addr = 39 | match (List.assoc "mtgox" config) with 40 | | [key; secret; addr] -> 41 | Uuidm.to_bytes (Opt.unbox (Uuidm.of_string key)), 42 | Cohttp.Base64.decode secret, addr 43 | | _ -> failwith "Syntax error in config file." 44 | (* and btce_key, btce_secret, btce_addr = *) 45 | (* match (List.assoc "btce" config) with *) 46 | (* | [key; secret; addr] -> key, secret, addr *) 47 | (* | _ -> failwith "Syntax error in config file." *) 48 | and bs_login, bs_passwd, bs_addr = 49 | match (List.assoc "bitstamp" config) with 50 | | [login; passwd; addr] -> login, passwd, addr 51 | | _ -> failwith "Syntax error in config file." 52 | in 53 | let ustream, push_f = Lwt_stream.create () in 54 | let exchanges_assq = 55 | ["mtgox", (new Mtgox.mtgox mtgox_key mtgox_secret mtgox_addr push_f 56 | :> Exchange.exchange); 57 | (* "btce", (new Btce.btce btce_key btce_secret btce_addr push_f *) 58 | (* :> Exchange.exchange); *) 59 | "bitstamp", (new Bitstamp_plugin.bitstamp bs_login bs_passwd bs_addr push_f 60 | :> Exchange.exchange) 61 | ] in 62 | let exchanges = List.map snd exchanges_assq in 63 | let rec process ustream = 64 | lwt updated_xch = Lwt_stream.get ustream >|= Opt.unbox in 65 | let updated_xchs = List.assoc updated_xch exchanges_assq in 66 | let arbiter_all xch = 67 | let other_xchs = List.filter (fun x -> x != xch) exchanges in 68 | let arbiter_one x1 x2 = 69 | try_lwt 70 | let direction, (_, qty, spr, bpr) = Books.arbiter_unsafe 71 | "USD" x1#get_books x2#get_books nb_of_iter min_ratio in 72 | let real_gain, ratio = 73 | let bfees, sfees = if direction then x1#fee, x2#fee 74 | else x2#fee, x1#fee in 75 | let spr_float, bpr_float = S.to_float spr, S.to_float bpr in 76 | let gain_float = (spr_float *. sfees -. bpr_float *. bfees) in 77 | gain_float /. 1e16, gain_float /. bpr_float in 78 | Lwt_log.notice_f "%s\t %s \t%s: %f (%f USD, %f %%)\n%!" 79 | x1#name 80 | ((function true -> "->"| false -> "<-") direction) 81 | x2#name 82 | (S.to_face_float qty) real_gain (ratio *. 100.0) 83 | with Not_found -> Lwt.return () in 84 | Lwt_list.iter_s (fun x -> arbiter_one xch x) other_xchs in 85 | arbiter_all updated_xchs >> process ustream 86 | in 87 | Lwt.join @@ process ustream :: List.map (fun xch -> xch#update) exchanges 88 | 89 | let () = Lwt_main.run @@ main () 90 | -------------------------------------------------------------------------------- /src/cli.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2012 Vincent Bernardoff 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | open Utils 19 | open Lwt_utils 20 | open Common 21 | 22 | let config = Config.of_file "breakbot.conf" 23 | let mtgox_key, mtgox_secret, mtgox_addr = 24 | match (List.assoc "mtgox" config) with 25 | | [key; secret; addr] -> 26 | Uuidm.to_bytes (Opt.unbox (Uuidm.of_string key)), 27 | Cohttp.Base64.decode secret, addr 28 | | _ -> failwith "Syntax error in config file." 29 | and btce_key, btce_secret, btce_addr = 30 | match (List.assoc "btce" config) with 31 | | [key; secret; addr] -> key, secret, addr 32 | | _ -> failwith "Syntax error in config file." 33 | and bstamp_l, bstamp_p, bstamp_addr = 34 | match (List.assoc "bitstamp" config) with 35 | | [login; passwd; addr] -> login, passwd, addr 36 | | _ -> failwith "Syntax error in config file." 37 | 38 | let exchanges = [ 39 | (new Mtgox.mtgox mtgox_key mtgox_secret mtgox_addr ignore :> Exchange.exchange); 40 | (new Btce.btce btce_key btce_secret btce_addr ignore :> Exchange.exchange); 41 | (new Bitstamp_plugin.bitstamp bstamp_key bstamp_secret bstamp_addr ignore :> Exchange.exchange) 42 | ] 43 | 44 | let print_balances ?curr xchs = 45 | lwt balances = Lwt_list.map_p 46 | (fun x -> x#get_balances >|= fun b -> x#name, b) xchs in 47 | Lwt_list.iter_s (fun (name, balances) -> 48 | Lwt_list.iter_s (fun (c, b) -> 49 | let str = 50 | Printf.sprintf "%s %s:\t%f\n%!" name c (S.to_face_float b) in 51 | match curr with 52 | | Some n -> if c = n then Lwt_io.print str else Lwt.return () 53 | | None -> Lwt_io.print str ) 54 | balances) balances 55 | 56 | let print_tickers ?curr xchs = 57 | let open Ticker in 58 | lwt tickers = Lwt_list.map_p 59 | (fun x -> x#get_tickers >|= fun t -> x#name, t) xchs in 60 | Lwt_list.iter_s (fun (name, tickers) -> 61 | Lwt_list.iter_s (fun (c, t) -> 62 | let str = 63 | Printf.sprintf "%s %s:\t%.2f %.2f %.2f\n%!" 64 | name c 65 | (S.to_face_float t.bid) 66 | (S.to_face_float t.ask) 67 | (S.to_face_float t.last) in 68 | match curr with 69 | | Some n -> if c = n then Lwt_io.print str else Lwt.return () 70 | | None -> Lwt_io.print str 71 | ) tickers) tickers 72 | 73 | let run_print_fun xch curr f = 74 | let xchs = match xch with 75 | | Some name -> List.filter (fun x -> x#name = name) exchanges 76 | | None -> exchanges in 77 | if xchs = [] 78 | then `Error (false, 79 | Printf.sprintf "Exchange %s unknown" (Opt.unbox xch)) 80 | else `Ok (f ?curr xchs) 81 | 82 | let place_order xch kind curr price amount = 83 | try_lwt 84 | let xch = List.find (fun x -> x#name = xch) exchanges in 85 | lwt rpc = 86 | xch#place_order kind curr 87 | (S.of_face_float price) (S.of_face_float amount) 88 | in Lwt_io.printl @@ Jsonrpc.to_string rpc 89 | with 90 | | Not_found -> Lwt_io.eprintf "Exchange %s unknown\n" xch 91 | | Failure msg -> Lwt_io.eprintl msg 92 | 93 | let withdraw_btc xch amount address = 94 | try_lwt 95 | let xch = List.find (fun x -> x#name = xch) exchanges in 96 | let address = 97 | if address.[0] = '1' then address else 98 | let target_xch = 99 | try List.find (fun x -> x#name = address) exchanges 100 | with Not_found -> 101 | failwith (Printf.sprintf "Exchange %s unknown" address) in 102 | target_xch#get_btc_addr in 103 | lwt rpc = 104 | xch#withdraw_btc (S.of_face_float amount) address 105 | in Lwt_io.printl @@ Jsonrpc.to_string rpc 106 | with 107 | | Not_found -> Lwt_io.eprintf "Exchange %s unknown\n" xch 108 | | Failure msg -> Lwt_io.eprintl msg 109 | 110 | open Cmdliner 111 | 112 | (* Arguments *) 113 | 114 | let currency_arg = 115 | let doc = "Currency to use, defaults to USD." in 116 | Arg.(value & opt string "USD" & info ~doc ~docv:"CURRENCY" 117 | ["c";"curr";"currency"]) 118 | 119 | (* Commands *) 120 | 121 | let buy_cmd = 122 | let exchange_arg = 123 | let doc = "Exchange to use." in 124 | Arg.(required & pos 0 (some string) None & info ~doc [] ~docv:"EXCHANGE") 125 | and amount_arg = 126 | let doc = "Amount of BTC." in 127 | Arg.(required & pos 1 (some float) None & info ~doc [] ~docv:"AMOUNT") 128 | and price_arg = 129 | let doc = "Price for 1BTC in currency." in 130 | Arg.(required & pos 2 (some float) None & info ~doc [] ~docv:"PRICE") 131 | and doc = "Buy bitcoins." in 132 | Term.(pure place_order $ exchange_arg $ pure Order.Bid 133 | $ currency_arg $ price_arg $ amount_arg), 134 | Term.info "buy" ~doc 135 | 136 | let sell_cmd = 137 | let exchange_arg = 138 | let doc = "Exchange to use." in 139 | Arg.(required & pos 0 (some string) None & info ~doc [] ~docv:"EXCHANGE") 140 | and amount_arg = 141 | let doc = "Amount of BTC." in 142 | Arg.(required & pos 1 (some float) None & info ~doc [] ~docv:"AMOUNT") 143 | and price_arg = 144 | let doc = "Price for 1BTC in currency." in 145 | Arg.(required & pos 2 (some float) None & info ~doc [] ~docv:"PRICE") 146 | and doc = "Sell bitcoins." in 147 | Term.(pure place_order $ exchange_arg $ pure Order.Ask 148 | $ currency_arg $ price_arg $ amount_arg), 149 | Term.info "sell" ~doc 150 | 151 | let ticker_cmd = 152 | let exchange_arg = 153 | let doc = "Exchange you want tickers from, defaults to all." in 154 | Arg.(value & pos 0 (some string) None & info ~doc [] ~docv:"EXCHANGE") 155 | and currency_arg = 156 | let doc = "Currency that will be displayed, defaults to all." in 157 | Arg.(value & pos 1 (some string) None & info ~doc [] ~docv:"CURRENCY") 158 | and doc = "Display ticker for one or more exchange(s)." in 159 | Term.(ret (pure run_print_fun $ exchange_arg 160 | $ currency_arg $ pure print_tickers)), 161 | Term.info "ticker" ~doc 162 | 163 | let balance_cmd = 164 | let exchange_arg = 165 | let doc = "Exchange you want balances from, defaults to all." in 166 | Arg.(value & pos 0 (some string) None & info ~doc [] ~docv:"EXCHANGE") 167 | and currency_arg = 168 | let doc = "Currency that will be displayed, defaults to all." in 169 | Arg.(value & pos 1 (some string) None & info ~doc [] ~docv:"CURRENCY") 170 | and doc = "Display balance for one or more exchange(s)." in 171 | Term.(ret (pure run_print_fun $ exchange_arg 172 | $ currency_arg $ pure print_balances)), 173 | Term.info "balance" ~doc 174 | 175 | let withdraw_cmd = 176 | let exchange_arg = 177 | let doc = "Exchange to use." in 178 | Arg.(required & pos 0 (some string) None & info ~doc [] ~docv:"EXCHANGE") 179 | and amount_arg = 180 | let doc = "Amount of BTC." in 181 | Arg.(required & pos 1 (some float) None & info ~doc [] ~docv:"AMOUNT") 182 | and addr_arg = 183 | let doc = "BTC destination address." in 184 | Arg.(required & pos 2 (some string) None & info ~doc [] ~docv:"PRICE") 185 | and doc = "Withdraw bitcoins" in 186 | Term.(pure withdraw_btc $ exchange_arg $ amount_arg $ addr_arg), 187 | Term.info "withdraw" ~doc 188 | 189 | let move_cmd = 190 | let doc = "Perform arbitrage between two exchanges." in 191 | Term.(pure (Lwt.return ())), 192 | Term.info "move" ~doc 193 | 194 | let exchange_cmd = 195 | let doc = "Display available exchanges." in 196 | Term.(pure (fun () -> Lwt_list.iter_s 197 | (fun x -> Lwt_io.printf "%s\t" x#name) 198 | exchanges >>= fun _ -> Lwt_io.print "\n") $ pure ()), 199 | Term.info "exchange" ~doc 200 | 201 | let default_cmd = 202 | let doc = "A CLI to interact with bitcoin exchanges." in 203 | Term.(ret (pure (`Help (`Pager, None)))), 204 | Term.info "cli" ~version:"0.1" ~doc 205 | 206 | let cmds = [exchange_cmd; buy_cmd; sell_cmd; ticker_cmd; 207 | balance_cmd; withdraw_cmd; move_cmd] 208 | 209 | let main = match Term.eval_choice default_cmd cmds with 210 | | `Ok x -> x | _ -> exit 1 211 | 212 | let () = Lwt_main.run main 213 | --------------------------------------------------------------------------------