├── META ├── Makefile ├── README ├── _tags ├── examples ├── Makefile ├── localhost │ ├── Makefile │ ├── _tags │ ├── certificate.pem │ ├── client.ml │ ├── myocamlbuild.ml │ ├── private_key.pem │ ├── server.cfg │ └── server.ml └── term.ie │ ├── Makefile │ ├── _tags │ ├── client.ml │ ├── myocamlbuild.ml │ └── private_key.pem ├── myocamlbuild.ml ├── oauth_base32.ml ├── oauth_base32.mli ├── oauth_client.ml ├── oauth_client.mli ├── oauth_common.ml ├── oauth_netcgi_http.ml ├── oauth_netclient_http_client.ml ├── oauth_ocurl_http_client.ml ├── oauth_server.ml ├── oauth_server.mli ├── oauth_util.ml ├── ooauth.mllib └── pem2cryptokit.c /META: -------------------------------------------------------------------------------- 1 | name="OOAuth" 2 | version="0.1" 3 | description="OAuth implementation" 4 | requires="cryptokit,netstring,ocurl,netclient" 5 | archive(byte) = "ooauth.cma" 6 | archive(native) = "ooauth.cmxa" 7 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | OCAMLDIR=`ocamlfind printconf stdlib` 2 | FILES=\ 3 | ooauth.cma ooauth.cmxa ooauth.a \ 4 | oauth_client.mli oauth_client.cmi \ 5 | oauth_server.mli oauth_server.cmi \ 6 | oauth_base32.mli oauth_base32.cmi \ 7 | oauth_util.cmi \ 8 | oauth_ocurl_http_client.cmi \ 9 | oauth_netclient_http_client.cmi \ 10 | oauth_netcgi_http.cmi 11 | 12 | BFILES=$(addprefix _build/,$(FILES)) 13 | 14 | all: pem2cryptokit 15 | ocamlbuild ooauth.cma ooauth.cmxa 16 | 17 | pem2cryptokit: pem2cryptokit.c 18 | gcc -g -I$(OCAMLDIR) pem2cryptokit.c -L$(OCAMLDIR) -lssl -lcrypto -lcamlrun -lm -o pem2cryptokit 19 | 20 | install: all 21 | ocamlfind install ooauth META $(BFILES) 22 | cp pem2cryptokit $(OCAMLDIR)/../../bin 23 | 24 | uninstall: 25 | ocamlfind remove ooauth 26 | 27 | clean: 28 | ocamlbuild -clean 29 | rm -f pem2cryptokit 30 | $(MAKE) -C examples clean 31 | 32 | dist: clean 33 | cd ..; tar cvfz ooauth.tar.gz --exclude .svn ooauth 34 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | This is OOAuth, OAuth for OCaml, version 0.1. 2 | 3 | Requirements: 4 | 5 | Cryptokit, Ocamlnet, Ocurl is optional. 6 | 7 | To configure: 8 | 9 | If you don't have Ocurl, remove references to it from ooauth.mllib, META, and FILES in Makefile. 10 | 11 | To install: 12 | 13 | make 14 | make install 15 | 16 | After installing, try the example in examples/term.ie/. 17 | -------------------------------------------------------------------------------- /_tags: -------------------------------------------------------------------------------- 1 | <*.ml*> : debug,pkg_cryptokit,pkg_netstring 2 | : pkg_curl 3 | : pkg_netclient 4 | : pkg_netcgi2 5 | -------------------------------------------------------------------------------- /examples/Makefile: -------------------------------------------------------------------------------- 1 | clean: 2 | $(MAKE) -C localhost clean 3 | $(MAKE) -C term.ie clean 4 | -------------------------------------------------------------------------------- /examples/localhost/Makefile: -------------------------------------------------------------------------------- 1 | all: private_key.ocaml certificate.ocaml 2 | ocamlbuild client.byte server.byte 3 | 4 | private_key.ocaml: private_key.pem 5 | pem2cryptokit < private_key.pem > private_key.ocaml 6 | 7 | certificate.ocaml: certificate.pem 8 | pem2cryptokit --certificate < certificate.pem > certificate.ocaml 9 | 10 | clean: 11 | ocamlbuild -clean 12 | rm -f private_key.ocaml certificate.ocaml 13 | -------------------------------------------------------------------------------- /examples/localhost/_tags: -------------------------------------------------------------------------------- 1 | <*.ml*> : debug,pkg_ooauth 2 | <*.byte> : debug,pkg_ooauth 3 | : pkg_netplex,pkg_nethttpd 4 | : pkg_netplex,pkg_nethttpd 5 | -------------------------------------------------------------------------------- /examples/localhost/certificate.pem: -------------------------------------------------------------------------------- 1 | -----BEGIN CERTIFICATE----- 2 | MIIBpjCCAQ+gAwIBAgIBATANBgkqhkiG9w0BAQUFADAZMRcwFQYDVQQDDA5UZXN0 3 | IFByaW5jaXBhbDAeFw03MDAxMDEwODAwMDBaFw0zODEyMzEwODAwMDBaMBkxFzAV 4 | BgNVBAMMDlRlc3QgUHJpbmNpcGFsMIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKB 5 | gQC0YjCwIfYoprq/FQO6lb3asXrxLlJFuCvtinTF5p0GxvQGu5O3gYytUvtC2JlY 6 | zypSRjVxwxrsuRcP3e641SdASwfrmzyvIgP08N4S0IFzEURkV1wp/IpH7kH41Etb 7 | mUmrXSwfNZsnQRE5SYSOhh+LcK2wyQkdgcMv11l4KoBkcwIDAQABMA0GCSqGSIb3 8 | DQEBBQUAA4GBAGZLPEuJ5SiJ2ryq+CmEGOXfvlTtEL2nuGtr9PewxkgnOjZpUy+d 9 | 4TvuXJbNQc8f4AMWL/tO9w0Fk80rWKp9ea8/df4qMq5qlFWlx6yOLQxumNOmECKb 10 | WpkUQDIDJEoFUzKMVuJf4KO/FJ345+BNLGgbJ6WujreoM1X/gYfdnJ/J 11 | -----END CERTIFICATE----- 12 | -------------------------------------------------------------------------------- /examples/localhost/client.ml: -------------------------------------------------------------------------------- 1 | (* works against local test server *) 2 | 3 | (* 4 | unfortunately Oauth_ocurl_http_client does not work with the test 5 | server (checked with curl 7.18.1 and Ocamlnet 2.2.9) because of a 6 | problem with the 100 Continue status line--Ocurl returns the 100 7 | status instead of the real status. not sure who is at fault. 8 | *) 9 | module OC = Oauth_client.Make(Oauth_netclient_http_client) 10 | 11 | let rsa_key = input_value (open_in "private_key.ocaml") 12 | let oauth_signature_method = `Rsa_sha1 rsa_key 13 | let http_method = `Post 14 | 15 | let url s = "http://localhost:8767" ^ s 16 | 17 | ;; 18 | 19 | let (oauth_token, oauth_token_secret) = 20 | OC.fetch_request_token 21 | ~http_method ~url:(url "/request_token") 22 | ~oauth_signature_method 23 | ~oauth_consumer_key:"key" ~oauth_consumer_secret:"secret" 24 | () in 25 | prerr_endline ("oauth_token = " ^ oauth_token); 26 | prerr_endline ("oauth_token_secret = " ^ oauth_token_secret); 27 | 28 | ignore(Oauth_netclient_http_client.request 29 | ~http_method:`Post 30 | ~url:(url "/authorize") 31 | ~params:["oauth_token", oauth_token] 32 | ()); 33 | 34 | let (oauth_token, oauth_token_secret) = 35 | OC.fetch_access_token 36 | ~http_method ~url:(url "/access_token") 37 | ~oauth_signature_method 38 | ~oauth_consumer_key:"key" ~oauth_consumer_secret:"secret" 39 | ~oauth_token ~oauth_token_secret 40 | () in 41 | prerr_endline ("oauth_token = " ^ oauth_token); 42 | prerr_endline ("oauth_token_secret = " ^ oauth_token_secret); 43 | 44 | let res = 45 | OC.access_resource 46 | ~http_method ~url:(url "/echo") 47 | ~oauth_signature_method 48 | ~oauth_consumer_key:"key" ~oauth_consumer_secret:"secret" 49 | ~oauth_token ~oauth_token_secret 50 | ~params:["method", "foo"; "bar", "baz"] 51 | () in 52 | prerr_endline ("res = " ^ res); 53 | -------------------------------------------------------------------------------- /examples/localhost/myocamlbuild.ml: -------------------------------------------------------------------------------- 1 | open Ocamlbuild_plugin 2 | 3 | (* ocamlfind integration following http://www.nabble.com/forum/ViewPost.jtp?post=15979274 *) 4 | 5 | (* these functions are not really officially exported *) 6 | let run_and_read = Ocamlbuild_pack.My_unix.run_and_read 7 | let blank_sep_strings = Ocamlbuild_pack.Lexers.blank_sep_strings 8 | 9 | (* this lists all supported packages *) 10 | let find_packages () = 11 | blank_sep_strings & 12 | Lexing.from_string & 13 | run_and_read "ocamlfind list | cut -d' ' -f1" 14 | 15 | (* ocamlfind command *) 16 | let ocamlfind x = S[A"ocamlfind"; x] 17 | 18 | ;; 19 | 20 | dispatch begin function 21 | | Before_options -> 22 | 23 | (* override default commands by ocamlfind ones *) 24 | Options.ocamlc := ocamlfind & A"ocamlc"; 25 | Options.ocamlopt := ocamlfind & A"ocamlopt"; 26 | Options.ocamldep := ocamlfind & A"ocamldep"; 27 | Options.ocamldoc := ocamlfind & A"ocamldoc" 28 | 29 | | After_rules -> 30 | 31 | (* When one link an OCaml library/binary/package, one should use -linkpkg *) 32 | flag ["ocaml"; "link"] & A"-linkpkg"; 33 | 34 | (* For each ocamlfind package one inject the -package option when 35 | * compiling, computing dependencies, generating documentation and 36 | * linking. *) 37 | List.iter begin fun pkg -> 38 | flag ["ocaml"; "compile"; "pkg_"^pkg] & S[A"-package"; A pkg]; 39 | flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S[A"-package"; A pkg]; 40 | flag ["ocaml"; "doc"; "pkg_"^pkg] & S[A"-package"; A pkg]; 41 | flag ["ocaml"; "link"; "pkg_"^pkg] & S[A"-package"; A pkg]; 42 | end (find_packages ()); 43 | 44 | | _ -> () 45 | end 46 | -------------------------------------------------------------------------------- /examples/localhost/private_key.pem: -------------------------------------------------------------------------------- 1 | -----BEGIN PRIVATE KEY----- 2 | MIICdgIBADANBgkqhkiG9w0BAQEFAASCAmAwggJcAgEAAoGBALRiMLAh9iimur8V 3 | A7qVvdqxevEuUkW4K+2KdMXmnQbG9Aa7k7eBjK1S+0LYmVjPKlJGNXHDGuy5Fw/d 4 | 7rjVJ0BLB+ubPK8iA/Tw3hLQgXMRRGRXXCn8ikfuQfjUS1uZSatdLB81mydBETlJ 5 | hI6GH4twrbDJCR2Bwy/XWXgqgGRzAgMBAAECgYBYWVtleUzavkbrPjy0T5FMou8H 6 | X9u2AC2ry8vD/l7cqedtwMPp9k7TubgNFo+NGvKsl2ynyprOZR1xjQ7WgrgVB+mm 7 | uScOM/5HVceFuGRDhYTCObE+y1kxRloNYXnx3ei1zbeYLPCHdhxRYW7T0qcynNmw 8 | rn05/KO2RLjgQNalsQJBANeA3Q4Nugqy4QBUCEC09SqylT2K9FrrItqL2QKc9v0Z 9 | zO2uwllCbg0dwpVuYPYXYvikNHHg+aCWF+VXsb9rpPsCQQDWR9TT4ORdzoj+Nccn 10 | qkMsDmzt0EfNaAOwHOmVJ2RVBspPcxt5iN4HI7HNeG6U5YsFBb+/GZbgfBT3kpNG 11 | WPTpAkBI+gFhjfJvRw38n3g/+UeAkwMI2TJQS4n8+hid0uus3/zOjDySH3XHCUno 12 | cn1xOJAyZODBo47E+67R4jV1/gzbAkEAklJaspRPXP877NssM5nAZMU0/O/NGCZ+ 13 | 3jPgDUno6WbJn5cqm8MqWhW1xGkImgRk+fkDBquiq4gPiT898jusgQJAd5Zrr6Q8 14 | AO/0isr/3aa6O6NLQxISLKcPDk2NOccAfS/xOtfOz4sJYM3+Bs4Io9+dZGSDCA54 15 | Lw03eHTNQghS0A== 16 | -----END PRIVATE KEY----- 17 | -------------------------------------------------------------------------------- /examples/localhost/server.cfg: -------------------------------------------------------------------------------- 1 | netplex { 2 | service { 3 | name = "nethttpd"; 4 | protocol { 5 | name = "http"; 6 | address { type = "internet"; bind = "localhost:8767"; }; 7 | }; 8 | processor { 9 | type = "nethttpd"; 10 | host { 11 | pref_name = "localhost"; 12 | pref_port = 8767; 13 | names = "*:0"; 14 | uri { 15 | path = "/"; 16 | service { 17 | type = "dynamic"; 18 | handler = "oauth" 19 | }; 20 | }; 21 | }; 22 | }; 23 | workload_manager { 24 | type = "constant"; 25 | threads = 1; 26 | }; 27 | }; 28 | } 29 | -------------------------------------------------------------------------------- /examples/localhost/server.ml: -------------------------------------------------------------------------------- 1 | module Db = 2 | struct 3 | 4 | module Http = Oauth_netcgi_http 5 | 6 | type consumer = string * string * Cryptokit.RSA.key 7 | let consumers = ["key", "secret", input_value (open_in "certificate.ocaml") ] 8 | let lookup_consumer k = List.find (fun (k',_,_) -> k' = k) consumers 9 | let consumer_key (k,_,_) = k 10 | let consumer_secret (_,s,_) = s 11 | let consumer_rsa_key (_,_,r) = r 12 | 13 | type request_token = consumer * string * string * bool ref 14 | let request_tokens = ref ([] : request_token list) 15 | let make_request_token c _ = 16 | let t = (c, Oauth_util.make_key (), Oauth_util.make_key (), ref false) in 17 | request_tokens := t::!request_tokens; 18 | t 19 | let lookup_request_token k = List.find (fun (_,k',_,_) -> k' = k) !request_tokens 20 | let request_token_check_consumer (c,_,_,_) c' = c = c' 21 | let request_token_token (_,k,_,_) = k 22 | let request_token_secret (_,_,s,_) = s 23 | let request_token_authorized (_,_,_,a) = !a 24 | let authorize_request_token (_,_,_,a) _ = a := true 25 | 26 | type access_token = consumer * string * string 27 | let access_tokens = ref [] 28 | let exchange_request_token ((c,k,s,a) as rt) = 29 | if not !a 30 | then raise (Failure "access token not authorized"); 31 | request_tokens := List.filter (fun rt' -> rt' <> rt) !request_tokens; 32 | let t = (c, Oauth_util.make_key (), Oauth_util.make_key ()) in 33 | access_tokens := t::!access_tokens; 34 | t 35 | let lookup_access_token k = List.find (fun (_,k',_) -> k' = k) !access_tokens 36 | let access_token_check_consumer (c,_,_) c' = c = c' 37 | let access_token_token (_,k,_) = k 38 | let access_token_secret (_,_,s) = s 39 | 40 | end 41 | 42 | module OS = Oauth_server.Make(Oauth_netcgi_http)(Db) 43 | 44 | let authorize_get oauth_token request_token (cgi : Netcgi_types.cgi_activation) = 45 | Oauth_netcgi_http.respond cgi `Ok [] 46 | (Printf.sprintf 47 | " 48 | 49 | Authorize 50 | 51 |
52 | 53 | 54 | 55 |
56 | 57 | 58 | " 59 | (cgi#url ()) 60 | oauth_token 61 | (cgi#argument_value "oauth_callback")) 62 | 63 | let authorize_post oauth_token request_token (cgi : Netcgi_types.cgi_activation) = 64 | let oauth_callback = cgi#argument_value "oauth_callback" in 65 | match oauth_callback with 66 | | "" -> Oauth_netcgi_http.respond cgi `Ok [] 67 | " 68 | 69 | Authorized! 70 | 71 |

Authorized!

72 | 73 | 74 | " 75 | | _ -> Oauth_netcgi_http.respond cgi `Found ["Location", oauth_callback] "" 76 | 77 | let echo oauth_token access_token (cgi : Netcgi_types.cgi_activation) = 78 | Oauth_netcgi_http.respond cgi `Ok [] (Netencoding.Url.mk_url_encoded_parameters (Oauth_netcgi_http.arguments cgi)) 79 | 80 | let oauth_cgi_handler (cgi : Netcgi_types.cgi_activation) = 81 | let url = cgi#url ~with_authority:`None () in 82 | match Neturl.split_path url with 83 | | [ _; "request_token" ] -> OS.fetch_request_token cgi 84 | | [ _; "authorize" ] -> OS.authorize_request_token cgi authorize_get authorize_post 85 | | [ _; "access_token" ] -> OS.fetch_access_token cgi 86 | | [ _; "echo" ] -> OS.access_resource cgi echo 87 | | _ -> Oauth_netcgi_http.respond cgi `Not_found [] "" 88 | 89 | let oauth_handler = { 90 | Nethttpd_services.dyn_handler = (fun _ -> oauth_cgi_handler); 91 | dyn_activation = Nethttpd_services.std_activation `Std_activation_buffered; 92 | dyn_uri = None; 93 | dyn_translator = (fun _ -> ""); 94 | dyn_accept_all_conditionals = false; 95 | } 96 | 97 | let start() = 98 | let (opt_list, cmdline_cfg) = Netplex_main.args() in 99 | 100 | Arg.parse 101 | opt_list 102 | (fun s -> raise (Arg.Bad ("Don't know what to do with: " ^ s))) 103 | "usage: netplex [options]"; 104 | 105 | let factories = 106 | [ Nethttpd_plex.nethttpd_factory ~handlers:[ "oauth", oauth_handler ] () ] 107 | in 108 | 109 | Netplex_main.startup 110 | (Netplex_mp.mp()) 111 | Netplex_log.logger_factories 112 | Netplex_workload.workload_manager_factories 113 | factories 114 | cmdline_cfg 115 | ;; 116 | 117 | Sys.set_signal Sys.sigpipe Sys.Signal_ignore; 118 | start() 119 | ;; 120 | -------------------------------------------------------------------------------- /examples/term.ie/Makefile: -------------------------------------------------------------------------------- 1 | all: private_key.ocaml 2 | ocamlbuild client.byte 3 | 4 | private_key.ocaml: private_key.pem 5 | pem2cryptokit < private_key.pem > private_key.ocaml 6 | 7 | clean: 8 | ocamlbuild -clean 9 | rm -f private_key.ocaml 10 | -------------------------------------------------------------------------------- /examples/term.ie/_tags: -------------------------------------------------------------------------------- 1 | <*.ml*> : debug,pkg_ooauth 2 | <*.byte> : debug,pkg_ooauth 3 | -------------------------------------------------------------------------------- /examples/term.ie/client.ml: -------------------------------------------------------------------------------- 1 | (* works against the term.ie test server *) 2 | 3 | module OC = Oauth_client.Make(Oauth_netclient_http_client) 4 | 5 | let rsa_key = input_value (open_in "private_key.ocaml") 6 | let oauth_signature_method = `Rsa_sha1 rsa_key 7 | let http_method = `Post 8 | 9 | let url s = "http://term.ie/oauth/example" ^ s 10 | 11 | ;; 12 | 13 | let (oauth_token, oauth_token_secret) = 14 | OC.fetch_request_token 15 | ~http_method ~url:(url "/request_token.php") 16 | ~oauth_signature_method 17 | ~oauth_consumer_key:"key" ~oauth_consumer_secret:"secret" 18 | () in 19 | prerr_endline ("oauth_token = " ^ oauth_token); 20 | prerr_endline ("oauth_token_secret = " ^ oauth_token_secret); 21 | 22 | let (oauth_token, oauth_token_secret) = 23 | OC.fetch_access_token 24 | ~http_method ~url:(url "/access_token.php") 25 | ~oauth_signature_method 26 | ~oauth_consumer_key:"key" ~oauth_consumer_secret:"secret" 27 | ~oauth_token ~oauth_token_secret 28 | () in 29 | prerr_endline ("oauth_token = " ^ oauth_token); 30 | prerr_endline ("oauth_token_secret = " ^ oauth_token_secret); 31 | 32 | let res = 33 | OC.access_resource 34 | ~http_method ~url:(url "/echo_api.php") 35 | ~oauth_signature_method 36 | ~oauth_consumer_key:"key" ~oauth_consumer_secret:"secret" 37 | ~oauth_token ~oauth_token_secret 38 | ~params:["method", "foo"; "bar", "baz"] 39 | () in 40 | prerr_endline ("res = " ^ res); 41 | -------------------------------------------------------------------------------- /examples/term.ie/myocamlbuild.ml: -------------------------------------------------------------------------------- 1 | open Ocamlbuild_plugin 2 | 3 | (* ocamlfind integration following http://www.nabble.com/forum/ViewPost.jtp?post=15979274 *) 4 | 5 | (* these functions are not really officially exported *) 6 | let run_and_read = Ocamlbuild_pack.My_unix.run_and_read 7 | let blank_sep_strings = Ocamlbuild_pack.Lexers.blank_sep_strings 8 | 9 | (* this lists all supported packages *) 10 | let find_packages () = 11 | blank_sep_strings & 12 | Lexing.from_string & 13 | run_and_read "ocamlfind list | cut -d' ' -f1" 14 | 15 | (* ocamlfind command *) 16 | let ocamlfind x = S[A"ocamlfind"; x] 17 | 18 | ;; 19 | 20 | dispatch begin function 21 | | Before_options -> 22 | 23 | (* override default commands by ocamlfind ones *) 24 | Options.ocamlc := ocamlfind & A"ocamlc"; 25 | Options.ocamlopt := ocamlfind & A"ocamlopt"; 26 | Options.ocamldep := ocamlfind & A"ocamldep"; 27 | Options.ocamldoc := ocamlfind & A"ocamldoc" 28 | 29 | | After_rules -> 30 | 31 | (* When one link an OCaml library/binary/package, one should use -linkpkg *) 32 | flag ["ocaml"; "link"] & A"-linkpkg"; 33 | 34 | (* For each ocamlfind package one inject the -package option when 35 | * compiling, computing dependencies, generating documentation and 36 | * linking. *) 37 | List.iter begin fun pkg -> 38 | flag ["ocaml"; "compile"; "pkg_"^pkg] & S[A"-package"; A pkg]; 39 | flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S[A"-package"; A pkg]; 40 | flag ["ocaml"; "doc"; "pkg_"^pkg] & S[A"-package"; A pkg]; 41 | flag ["ocaml"; "link"; "pkg_"^pkg] & S[A"-package"; A pkg]; 42 | end (find_packages ()); 43 | 44 | | _ -> () 45 | end 46 | -------------------------------------------------------------------------------- /examples/term.ie/private_key.pem: -------------------------------------------------------------------------------- 1 | -----BEGIN PRIVATE KEY----- 2 | MIICdgIBADANBgkqhkiG9w0BAQEFAASCAmAwggJcAgEAAoGBALRiMLAh9iimur8V 3 | A7qVvdqxevEuUkW4K+2KdMXmnQbG9Aa7k7eBjK1S+0LYmVjPKlJGNXHDGuy5Fw/d 4 | 7rjVJ0BLB+ubPK8iA/Tw3hLQgXMRRGRXXCn8ikfuQfjUS1uZSatdLB81mydBETlJ 5 | hI6GH4twrbDJCR2Bwy/XWXgqgGRzAgMBAAECgYBYWVtleUzavkbrPjy0T5FMou8H 6 | X9u2AC2ry8vD/l7cqedtwMPp9k7TubgNFo+NGvKsl2ynyprOZR1xjQ7WgrgVB+mm 7 | uScOM/5HVceFuGRDhYTCObE+y1kxRloNYXnx3ei1zbeYLPCHdhxRYW7T0qcynNmw 8 | rn05/KO2RLjgQNalsQJBANeA3Q4Nugqy4QBUCEC09SqylT2K9FrrItqL2QKc9v0Z 9 | zO2uwllCbg0dwpVuYPYXYvikNHHg+aCWF+VXsb9rpPsCQQDWR9TT4ORdzoj+Nccn 10 | qkMsDmzt0EfNaAOwHOmVJ2RVBspPcxt5iN4HI7HNeG6U5YsFBb+/GZbgfBT3kpNG 11 | WPTpAkBI+gFhjfJvRw38n3g/+UeAkwMI2TJQS4n8+hid0uus3/zOjDySH3XHCUno 12 | cn1xOJAyZODBo47E+67R4jV1/gzbAkEAklJaspRPXP877NssM5nAZMU0/O/NGCZ+ 13 | 3jPgDUno6WbJn5cqm8MqWhW1xGkImgRk+fkDBquiq4gPiT898jusgQJAd5Zrr6Q8 14 | AO/0isr/3aa6O6NLQxISLKcPDk2NOccAfS/xOtfOz4sJYM3+Bs4Io9+dZGSDCA54 15 | Lw03eHTNQghS0A== 16 | -----END PRIVATE KEY----- 17 | -------------------------------------------------------------------------------- /myocamlbuild.ml: -------------------------------------------------------------------------------- 1 | open Ocamlbuild_plugin 2 | 3 | (* ocamlfind integration following http://www.nabble.com/forum/ViewPost.jtp?post=15979274 *) 4 | 5 | (* these functions are not really officially exported *) 6 | let run_and_read = Ocamlbuild_pack.My_unix.run_and_read 7 | let blank_sep_strings = Ocamlbuild_pack.Lexers.blank_sep_strings 8 | 9 | (* this lists all supported packages *) 10 | let find_packages () = 11 | blank_sep_strings & 12 | Lexing.from_string & 13 | run_and_read "ocamlfind list | cut -d' ' -f1" 14 | 15 | (* ocamlfind command *) 16 | let ocamlfind x = S[A"ocamlfind"; x] 17 | 18 | ;; 19 | 20 | dispatch begin function 21 | | Before_options -> 22 | 23 | (* override default commands by ocamlfind ones *) 24 | Options.ocamlc := ocamlfind & A"ocamlc"; 25 | Options.ocamlopt := ocamlfind & A"ocamlopt"; 26 | Options.ocamldep := ocamlfind & A"ocamldep"; 27 | Options.ocamldoc := ocamlfind & A"ocamldoc" 28 | 29 | | After_rules -> 30 | 31 | (* When one link an OCaml library/binary/package, one should use -linkpkg *) 32 | flag ["ocaml"; "link"] & A"-linkpkg"; 33 | 34 | (* For each ocamlfind package one inject the -package option when 35 | * compiling, computing dependencies, generating documentation and 36 | * linking. *) 37 | List.iter begin fun pkg -> 38 | flag ["ocaml"; "compile"; "pkg_"^pkg] & S[A"-package"; A pkg]; 39 | flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S[A"-package"; A pkg]; 40 | flag ["ocaml"; "doc"; "pkg_"^pkg] & S[A"-package"; A pkg]; 41 | flag ["ocaml"; "link"; "pkg_"^pkg] & S[A"-package"; A pkg]; 42 | end (find_packages ()); 43 | 44 | | _ -> () 45 | end 46 | -------------------------------------------------------------------------------- /oauth_base32.ml: -------------------------------------------------------------------------------- 1 | (* http://www.crockford.com/wrmg/base32.html *) 2 | 3 | open Cryptokit 4 | 5 | (* adapted from Cryptokit.Base64 *) 6 | 7 | class buffered_output initial_buffer_size = 8 | object(self) 9 | val mutable obuf = String.create initial_buffer_size 10 | val mutable obeg = 0 11 | val mutable oend = 0 12 | 13 | method private ensure_capacity n = 14 | let len = String.length obuf in 15 | if oend + n > len then begin 16 | if oend - obeg + n < len then begin 17 | String.blit obuf obeg obuf 0 (oend - obeg); 18 | oend <- oend - obeg; 19 | obeg <- 0 20 | end else begin 21 | let newlen = min (2 * len) Sys.max_string_length in 22 | if oend - obeg + n > newlen then raise(Error Output_buffer_overflow); 23 | let newbuf = String.create newlen in 24 | String.blit obuf obeg newbuf 0 (oend - obeg); 25 | obuf <- newbuf; 26 | oend <- oend - obeg; 27 | obeg <- 0 28 | end 29 | end 30 | 31 | method available_output = oend - obeg 32 | 33 | method get_substring = 34 | let res = (obuf, obeg, oend - obeg) in obeg <- 0; oend <- 0; res 35 | 36 | method get_string = 37 | let res = String.sub obuf obeg (oend - obeg) in obeg <- 0; oend <- 0; res 38 | 39 | method get_char = 40 | if obeg >= oend then raise End_of_file; 41 | let r = obuf.[obeg] in 42 | obeg <- obeg + 1; 43 | r 44 | 45 | method get_byte = 46 | Char.code self#get_char 47 | 48 | method wipe = 49 | wipe_string obuf 50 | end 51 | 52 | let base32_conv_table = 53 | "0123456789abcdefghjkmnpqrstvwxyz" 54 | 55 | class encode = 56 | object (self) 57 | method input_block_size = 1 58 | method output_block_size = 1 59 | 60 | inherit buffered_output 256 as output_buffer 61 | 62 | val ibuf = String.create 5 63 | val mutable ipos = 0 64 | 65 | method put_char c = 66 | ibuf.[ipos] <- c; 67 | ipos <- ipos + 1; 68 | if ipos = 5 then begin 69 | let b0 = Char.code ibuf.[0] 70 | and b1 = Char.code ibuf.[1] 71 | and b2 = Char.code ibuf.[2] 72 | and b3 = Char.code ibuf.[3] 73 | and b4 = Char.code ibuf.[4] in 74 | self#ensure_capacity 8; 75 | obuf.[oend] <- base32_conv_table.[b0 lsr 3]; 76 | obuf.[oend+1] <- base32_conv_table.[(b0 land 7) lsl 2 + (b1 lsr 6)]; 77 | obuf.[oend+2] <- base32_conv_table.[(b1 land 62) lsr 1]; 78 | obuf.[oend+3] <- base32_conv_table.[(b1 land 1) lsl 4 + (b2 lsr 4)]; 79 | obuf.[oend+4] <- base32_conv_table.[(b2 land 15) lsl 1 + (b3 lsr 7)]; 80 | obuf.[oend+5] <- base32_conv_table.[(b3 land 124) lsr 2]; 81 | obuf.[oend+6] <- base32_conv_table.[(b3 land 3) lsl 3 + (b4 lsr 5)]; 82 | obuf.[oend+7] <- base32_conv_table.[b4 land 31]; 83 | oend <- oend + 8; 84 | ipos <- 0; 85 | end 86 | 87 | method put_substring s ofs len = 88 | for i = ofs to ofs + len - 1 do self#put_char s.[i] done 89 | 90 | method put_string s = 91 | self#put_substring s 0 (String.length s) 92 | 93 | method put_byte b = self#put_char (Char.chr b) 94 | 95 | method flush : unit = raise (Error Wrong_data_length) 96 | 97 | method finish = 98 | (* I wonder how to do Duff's Device in OCaml... *) 99 | begin match ipos with 100 | | 1 -> 101 | let b0 = Char.code ibuf.[0] in 102 | self#ensure_capacity 2; 103 | obuf.[oend] <- base32_conv_table.[b0 lsr 3]; 104 | obuf.[oend+1] <- base32_conv_table.[(b0 land 7) lsl 2]; 105 | oend <- oend + 2; 106 | | 2 -> 107 | let b0 = Char.code ibuf.[0] 108 | and b1 = Char.code ibuf.[1] in 109 | self#ensure_capacity 4; 110 | obuf.[oend] <- base32_conv_table.[b0 lsr 3]; 111 | obuf.[oend+1] <- base32_conv_table.[(b0 land 7) lsl 2 + (b1 lsr 6)]; 112 | obuf.[oend+2] <- base32_conv_table.[(b1 land 62) lsr 1]; 113 | obuf.[oend+3] <- base32_conv_table.[(b1 land 1) lsl 4]; 114 | oend <- oend + 4; 115 | | 3 -> 116 | let b0 = Char.code ibuf.[0] 117 | and b1 = Char.code ibuf.[1] 118 | and b2 = Char.code ibuf.[2] in 119 | self#ensure_capacity 5; 120 | obuf.[oend] <- base32_conv_table.[b0 lsr 3]; 121 | obuf.[oend+1] <- base32_conv_table.[(b0 land 7) lsl 2 + (b1 lsr 6)]; 122 | obuf.[oend+2] <- base32_conv_table.[(b1 land 62) lsr 1]; 123 | obuf.[oend+3] <- base32_conv_table.[(b1 land 1) lsl 4 + (b2 lsr 4)]; 124 | obuf.[oend+4] <- base32_conv_table.[(b2 land 15) lsl 1]; 125 | oend <- oend + 5; 126 | | 4 -> 127 | let b0 = Char.code ibuf.[0] 128 | and b1 = Char.code ibuf.[1] 129 | and b2 = Char.code ibuf.[2] 130 | and b3 = Char.code ibuf.[3] in 131 | self#ensure_capacity 7; 132 | obuf.[oend] <- base32_conv_table.[b0 lsr 3]; 133 | obuf.[oend+1] <- base32_conv_table.[(b0 land 7) lsl 2 + (b1 lsr 6)]; 134 | obuf.[oend+2] <- base32_conv_table.[(b1 land 62) lsr 1]; 135 | obuf.[oend+3] <- base32_conv_table.[(b1 land 1) lsl 4 + (b2 lsr 4)]; 136 | obuf.[oend+4] <- base32_conv_table.[(b2 land 15) lsl 1 + (b3 lsr 7)]; 137 | obuf.[oend+5] <- base32_conv_table.[(b3 land 124) lsr 2]; 138 | obuf.[oend+6] <- base32_conv_table.[(b3 land 3) lsl 3]; 139 | oend <- oend + 7; 140 | | _ -> () 141 | end 142 | 143 | method wipe = 144 | wipe_string ibuf; output_buffer#wipe 145 | end 146 | 147 | let encode () = new encode 148 | 149 | let base32_decode_char c = 150 | match c with 151 | | '0' | 'O' | 'o' -> 0 152 | | '1' | 'I' | 'i' | 'L' | 'l' -> 1 153 | | '2' .. '9' -> Char.code c - 48 154 | | 'A' .. 'H' -> Char.code c - 55 | 'a' .. 'h' -> Char.code c - 87 155 | | 'J' .. 'K' -> Char.code c - 56 | 'j' .. 'k' -> Char.code c - 88 156 | | 'M' .. 'N' -> Char.code c - 57 | 'm' .. 'n' -> Char.code c - 89 157 | | 'P' .. 'T' -> Char.code c - 58 | 'p' .. 't' -> Char.code c - 90 158 | | 'V' .. 'Z' -> Char.code c - 59 | 'v' .. 'z' -> Char.code c - 91 159 | | ' '|'\t'|'\n'|'\r' -> -1 160 | | _ -> raise (Error Bad_encoding) 161 | 162 | class decode = 163 | object (self) 164 | inherit buffered_output 256 as output_buffer 165 | 166 | method input_block_size = 1 167 | method output_block_size = 1 168 | 169 | val ibuf = Array.create 8 0 170 | val mutable ipos = 0 171 | val mutable finished = false 172 | 173 | method put_char c = 174 | if c = '=' then finished <- true else begin 175 | let n = base32_decode_char c in 176 | if n >= 0 then begin 177 | if finished then raise(Error Bad_encoding); 178 | ibuf.(ipos) <- n; 179 | ipos <- ipos + 1; 180 | if ipos = 8 then begin 181 | self#ensure_capacity 5; 182 | obuf.[oend] <- Char.chr(ibuf.(0) lsl 3 + ibuf.(1) lsr 2); 183 | obuf.[oend+1] <- Char.chr((ibuf.(1) land 3) lsl 6 + ibuf.(2) lsl 1 + ibuf.(3) lsr 4); 184 | obuf.[oend+2] <- Char.chr((ibuf.(3) land 15) lsl 4 + ibuf.(4) lsr 1); 185 | obuf.[oend+3] <- Char.chr((ibuf.(4) land 1) lsl 7 + ibuf.(5) lsl 2 + ibuf.(6) lsr 3); 186 | obuf.[oend+4] <- Char.chr((ibuf.(6) land 7) lsl 5 + ibuf.(7)); 187 | oend <- oend + 5; 188 | ipos <- 0 189 | end 190 | end 191 | end 192 | 193 | method put_substring s ofs len = 194 | for i = ofs to ofs + len - 1 do self#put_char s.[i] done 195 | 196 | method put_string s = 197 | self#put_substring s 0 (String.length s) 198 | 199 | method put_byte b = self#put_char (Char.chr b) 200 | 201 | method flush : unit = raise (Error Wrong_data_length) 202 | 203 | method finish = 204 | finished <- true; 205 | match ipos with 206 | | 1 -> raise(Error Bad_encoding) 207 | | 2 -> 208 | self#ensure_capacity 1; 209 | obuf.[oend] <- Char.chr(ibuf.(0) lsl 3 + ibuf.(1) lsr 2); 210 | oend <- oend + 1; 211 | | 3 -> raise(Error Bad_encoding) 212 | | 4 -> 213 | self#ensure_capacity 2; 214 | obuf.[oend] <- Char.chr(ibuf.(0) lsl 3 + ibuf.(1) lsr 2); 215 | obuf.[oend+1] <- Char.chr((ibuf.(1) land 3) lsl 6 + ibuf.(2) lsl 1 + ibuf.(3) lsr 4); 216 | oend <- oend + 2; 217 | | 5 -> 218 | self#ensure_capacity 3; 219 | obuf.[oend] <- Char.chr(ibuf.(0) lsl 3 + ibuf.(1) lsr 2); 220 | obuf.[oend+1] <- Char.chr((ibuf.(1) land 3) lsl 6 + ibuf.(2) lsl 1 + ibuf.(3) lsr 4); 221 | obuf.[oend+2] <- Char.chr((ibuf.(3) land 15) lsl 4 + ibuf.(4) lsr 1); 222 | oend <- oend + 3; 223 | | 6 -> raise(Error Bad_encoding) 224 | | 7 -> 225 | self#ensure_capacity 4; 226 | obuf.[oend] <- Char.chr(ibuf.(0) lsl 3 + ibuf.(1) lsr 2); 227 | obuf.[oend+1] <- Char.chr((ibuf.(1) land 3) lsl 6 + ibuf.(2) lsl 1 + ibuf.(3) lsr 4); 228 | obuf.[oend+2] <- Char.chr((ibuf.(3) land 15) lsl 4 + ibuf.(4) lsr 1); 229 | obuf.[oend+3] <- Char.chr((ibuf.(4) land 1) lsl 7 + ibuf.(5) lsl 2 + ibuf.(6) lsr 3); 230 | oend <- oend + 4; 231 | | _ -> () 232 | 233 | method wipe = 234 | Array.fill ibuf 0 8 0; output_buffer#wipe 235 | end 236 | 237 | let decode () = new decode 238 | -------------------------------------------------------------------------------- /oauth_base32.mli: -------------------------------------------------------------------------------- 1 | val encode : unit -> Cryptokit.transform 2 | val decode : unit -> Cryptokit.transform 3 | -------------------------------------------------------------------------------- /oauth_client.ml: -------------------------------------------------------------------------------- 1 | module type Http_client = 2 | sig 3 | val request : 4 | ?http_method:[ `Get | `Head | `Post ] -> 5 | url:string -> 6 | ?headers:(string * string) list -> 7 | ?params:(string * string) list -> 8 | ?body:string * string -> (* content type * body *) 9 | unit -> 10 | Nethttp.http_status * (string * string) list * string 11 | end 12 | 13 | module Make (Http_client : Http_client) = 14 | struct 15 | 16 | exception Error of Nethttp.http_status * string 17 | 18 | open Oauth_common 19 | 20 | 21 | 22 | let authorization_header 23 | ~oauth_version ~oauth_signature_method ~oauth_signature 24 | ~oauth_consumer_key ?oauth_token 25 | ~oauth_timestamp ~oauth_nonce 26 | () = 27 | let params = 28 | [ 29 | "OAuth realm", ""; 30 | "oauth_version", oauth_version; 31 | "oauth_signature_method", string_of_signature_method oauth_signature_method; 32 | "oauth_signature", oauth_signature; 33 | "oauth_consumer_key", oauth_consumer_key; 34 | "oauth_timestamp", string_of_timestamp oauth_timestamp; 35 | "oauth_nonce", oauth_nonce; 36 | ] @ 37 | opt_param "oauth_token" oauth_token in 38 | 39 | "Authorization", 40 | (params |> 41 | List.map (fun (k, v) -> k ^ "=\"" ^ String.escaped (rfc3986_encode v) ^ "\"") |> 42 | String.concat ",") 43 | 44 | 45 | 46 | let parse_response res = 47 | try 48 | let params = Netencoding.Url.dest_url_encoded_parameters res in 49 | (List.assoc "oauth_token" params, List.assoc "oauth_token_secret" params) 50 | with 51 | | _ -> raise (Error (`Internal_server_error, "bad response: " ^ res)) 52 | 53 | 54 | 55 | let fetch_request_token 56 | ?(http_method = `Post) ~url 57 | ?(oauth_version = "1.0") ?(oauth_signature_method = `Hmac_sha1) 58 | ~oauth_consumer_key ~oauth_consumer_secret 59 | ?(oauth_timestamp = make_timestamp ()) ?(oauth_nonce = make_nonce ()) 60 | ?params ?(headers = []) 61 | () = 62 | 63 | let oauth_signature = 64 | sign 65 | ~http_method ~url 66 | ~oauth_version ~oauth_signature_method 67 | ~oauth_consumer_key ~oauth_consumer_secret 68 | ~oauth_timestamp ~oauth_nonce 69 | ?params 70 | () in 71 | 72 | let headers = 73 | authorization_header 74 | ~oauth_version ~oauth_signature_method ~oauth_signature 75 | ~oauth_consumer_key 76 | ~oauth_timestamp ~oauth_nonce 77 | () :: headers in 78 | 79 | let res = 80 | Http_client.request 81 | ~http_method 82 | ~url 83 | ~headers 84 | ?params 85 | () in 86 | 87 | match res with 88 | | (`Ok, _, res) -> parse_response res 89 | | (status, _, res) -> raise (Error (status, res)) 90 | 91 | 92 | 93 | let fetch_access_token 94 | ?(http_method = `Post) ~url 95 | ?(oauth_version = "1.0") ?(oauth_signature_method = `Hmac_sha1) 96 | ~oauth_consumer_key ~oauth_consumer_secret 97 | ~oauth_token ~oauth_token_secret 98 | ?(oauth_timestamp = make_timestamp ()) ?(oauth_nonce = make_nonce ()) 99 | ?(headers = []) 100 | () = 101 | 102 | let oauth_signature = 103 | sign 104 | ~http_method ~url 105 | ~oauth_version ~oauth_signature_method 106 | ~oauth_consumer_key ~oauth_consumer_secret 107 | ~oauth_token ~oauth_token_secret 108 | ~oauth_timestamp ~oauth_nonce 109 | () in 110 | 111 | let headers = 112 | authorization_header 113 | ~oauth_version ~oauth_signature_method ~oauth_signature 114 | ~oauth_consumer_key ~oauth_token 115 | ~oauth_timestamp ~oauth_nonce 116 | () :: headers in 117 | 118 | let res = 119 | Http_client.request 120 | ~http_method 121 | ~url 122 | ~headers 123 | () in 124 | 125 | match res with 126 | | (`Ok, _, res) -> parse_response res 127 | | (status, _, res) -> raise (Error (status, res)) 128 | 129 | 130 | 131 | let access_resource 132 | ?(http_method = `Post) ~url 133 | ?(oauth_version = "1.0") ?(oauth_signature_method = `Hmac_sha1) 134 | ~oauth_consumer_key ~oauth_consumer_secret 135 | ~oauth_token ~oauth_token_secret 136 | ?(oauth_timestamp = make_timestamp ()) ?(oauth_nonce = make_nonce ()) 137 | ?params ?(headers = []) ?body 138 | () = 139 | 140 | let oauth_signature = 141 | sign 142 | ~http_method ~url 143 | ~oauth_version ~oauth_signature_method 144 | ~oauth_consumer_key ~oauth_consumer_secret 145 | ~oauth_token ~oauth_token_secret 146 | ~oauth_timestamp ~oauth_nonce 147 | ?params 148 | () in 149 | 150 | let headers = 151 | authorization_header 152 | ~oauth_version ~oauth_signature_method ~oauth_signature 153 | ~oauth_consumer_key ~oauth_token 154 | ~oauth_timestamp ~oauth_nonce 155 | () :: headers in 156 | 157 | let res = 158 | Http_client.request 159 | ~http_method 160 | ~url 161 | ~headers 162 | ?params 163 | ?body 164 | () in 165 | 166 | match res with 167 | | (`Ok, _, res) -> res 168 | | (status, _, res) -> raise (Error (status, res)) 169 | 170 | end 171 | -------------------------------------------------------------------------------- /oauth_client.mli: -------------------------------------------------------------------------------- 1 | module type Http_client = 2 | sig 3 | val request : 4 | ?http_method:[ `Get | `Head | `Post ] -> 5 | url:string -> 6 | ?headers:(string * string) list -> 7 | ?params:(string * string) list -> 8 | ?body:string * string -> (* content type * body *) 9 | unit -> 10 | Nethttp.http_status * (string * string) list * string 11 | end 12 | 13 | module Make : functor (Http_client : Http_client) -> 14 | sig 15 | 16 | exception Error of Nethttp.http_status * string 17 | 18 | val fetch_request_token : 19 | ?http_method:[ `Get | `Head | `Post ] -> 20 | url:string -> 21 | ?oauth_version:string -> 22 | ?oauth_signature_method:[ `Plaintext | `Hmac_sha1 | `Rsa_sha1 of Cryptokit.RSA.key ] -> 23 | oauth_consumer_key:string -> 24 | oauth_consumer_secret:string -> 25 | ?oauth_timestamp:float -> 26 | ?oauth_nonce:string -> 27 | ?params:(string * string) list -> 28 | ?headers:(string * string) list -> 29 | unit -> 30 | string * string 31 | 32 | val fetch_access_token : 33 | ?http_method:[ `Get | `Head | `Post ] -> 34 | url:string -> 35 | ?oauth_version:string -> 36 | ?oauth_signature_method:[ `Plaintext | `Hmac_sha1 | `Rsa_sha1 of Cryptokit.RSA.key ] -> 37 | oauth_consumer_key:string -> 38 | oauth_consumer_secret:string -> 39 | oauth_token:string -> 40 | oauth_token_secret:string -> 41 | ?oauth_timestamp:float -> 42 | ?oauth_nonce:string -> 43 | ?headers:(string * string) list -> 44 | unit -> 45 | string * string 46 | 47 | val access_resource : 48 | ?http_method:[ `Get | `Head | `Post ] -> 49 | url:string -> 50 | ?oauth_version:string -> 51 | ?oauth_signature_method:[ `Plaintext | `Hmac_sha1 | `Rsa_sha1 of Cryptokit.RSA.key ] -> 52 | oauth_consumer_key:string -> 53 | oauth_consumer_secret:string -> 54 | oauth_token:string -> 55 | oauth_token_secret:string -> 56 | ?oauth_timestamp:float -> 57 | ?oauth_nonce:string -> 58 | ?params:(string * string) list -> 59 | ?headers:(string * string) list -> 60 | ?body:string * string -> (* content type * body *) 61 | unit -> 62 | string 63 | 64 | end 65 | -------------------------------------------------------------------------------- /oauth_common.ml: -------------------------------------------------------------------------------- 1 | let (|>) x f = f x (* so function pipelines read left to right *) 2 | 3 | let opt_param name param = 4 | match param with 5 | | None -> [] 6 | | Some p -> [name, p] 7 | 8 | let rng = Cryptokit.Random.device_rng "/dev/random" 9 | 10 | let rfc3986_encode s = Netencoding.Url.encode s 11 | let rfc3986_decode s = Netencoding.Url.decode s 12 | 13 | let string_of_http_method = function 14 | | `Get -> "GET" 15 | | `Post -> "POST" 16 | | `Head -> "HEAD" 17 | 18 | let string_of_signature_method = function 19 | | `Plaintext -> "PLAINTEXT" 20 | | `Hmac_sha1 -> "HMAC-SHA1" 21 | | `Rsa_sha1 _ -> "RSA-SHA1" 22 | 23 | let signature_method_of_string rsa_key = function 24 | | "PLAINTEXT" -> `Plaintext 25 | | "HMAC-SHA1" -> `Hmac_sha1 26 | | "RSA-SHA1" -> `Rsa_sha1 (rsa_key ()) 27 | | _ -> raise Not_found 28 | 29 | let normalize_url url = 30 | let url = Neturl.parse_url ~enable_fragment:true url in 31 | let url = Neturl.remove_from_url ~query:true ~fragment:true url in 32 | Neturl.string_of_url url 33 | 34 | let string_of_timestamp t = 35 | let s = string_of_float t in 36 | String.sub s 0 (String.length s - 1) 37 | 38 | let make_timestamp () = Unix.time () 39 | 40 | let make_nonce () = 41 | Cryptokit.Random.string rng 16 |> 42 | Cryptokit.transform_string (Cryptokit.Hexa.encode ()) 43 | 44 | let base64_encode v = 45 | let b64 = Cryptokit.transform_string (Cryptokit.Base64.encode_compact ()) v in 46 | b64 ^ "=" 47 | 48 | let base64_decode v = 49 | Cryptokit.transform_string (Cryptokit.Base64.decode ()) v 50 | 51 | let hmac_sha1_hash text key = 52 | text |> 53 | Cryptokit.hash_string (Cryptokit.MAC.hmac_sha1 key) |> 54 | base64_encode 55 | 56 | let sha1_digest_info h = 57 | "\x30\x21\x30\x09\x06\x05\x2b\x0e\x03\x02\x1a\x05\x00\x04\x14" ^ h 58 | 59 | let pkcs1_pad rsa_key v = 60 | let tLen = String.length v in 61 | let emLen = rsa_key.Cryptokit.RSA.size / 8 in 62 | "\x00\x01" ^ String.make (emLen - tLen - 3) '\xff' ^ "\x00" ^ v 63 | 64 | let rsa_sha1_hash text rsa_key = 65 | text |> 66 | Cryptokit.hash_string (Cryptokit.Hash.sha1 ()) |> 67 | sha1_digest_info |> 68 | pkcs1_pad rsa_key |> 69 | Cryptokit.RSA.sign rsa_key |> 70 | base64_encode 71 | 72 | let check_rsa_sha1_hash text rsa_key signature = 73 | try 74 | (text |> 75 | Cryptokit.hash_string (Cryptokit.Hash.sha1 ()) |> 76 | sha1_digest_info |> 77 | pkcs1_pad rsa_key) = 78 | (signature |> 79 | base64_decode |> 80 | Cryptokit.RSA.unwrap_signature rsa_key) 81 | with _ -> false 82 | 83 | 84 | 85 | let signature_base_string 86 | ~http_method ~url 87 | ~oauth_signature_method 88 | ~oauth_consumer_key ~oauth_consumer_secret 89 | ?oauth_token ?oauth_token_secret 90 | ~oauth_timestamp ~oauth_nonce ~oauth_version 91 | ?(params = []) 92 | () = 93 | 94 | let params = [ 95 | "oauth_signature_method", string_of_signature_method oauth_signature_method; 96 | "oauth_consumer_key", oauth_consumer_key; 97 | "oauth_timestamp", string_of_timestamp oauth_timestamp; 98 | "oauth_nonce", oauth_nonce; 99 | "oauth_version", oauth_version; 100 | ] @ 101 | opt_param "oauth_token" oauth_token @ 102 | List.filter (fun (k, v) -> k <> "oauth_signature") params in 103 | 104 | List.map rfc3986_encode 105 | [ 106 | string_of_http_method http_method; 107 | normalize_url url; 108 | 109 | params |> 110 | List.map (fun (k, v) -> rfc3986_encode k, rfc3986_encode v) |> 111 | List.sort (fun (k,v) (k',v') -> 112 | match String.compare k k' with 113 | | 0 -> String.compare v v' 114 | | c -> c) |> 115 | List.map (fun (k,v) -> k ^ "=" ^ v) |> 116 | String.concat "&" 117 | ] |> String.concat "&" 118 | 119 | 120 | 121 | let sign 122 | ~http_method ~url 123 | ~oauth_signature_method 124 | ~oauth_consumer_key ~oauth_consumer_secret 125 | ?oauth_token ?oauth_token_secret 126 | ~oauth_timestamp ~oauth_nonce ~oauth_version 127 | ?params 128 | () = 129 | 130 | let key = 131 | (rfc3986_encode oauth_consumer_secret ^ "&" ^ 132 | match oauth_token_secret with 133 | | None -> "" 134 | | Some s -> rfc3986_encode s) in 135 | 136 | let signature_base_string = 137 | signature_base_string 138 | ~http_method ~url 139 | ~oauth_signature_method 140 | ~oauth_consumer_key ~oauth_consumer_secret 141 | ?oauth_token ?oauth_token_secret 142 | ~oauth_timestamp ~oauth_nonce ~oauth_version 143 | ?params 144 | () in 145 | 146 | match oauth_signature_method with 147 | | `Plaintext -> rfc3986_encode key 148 | | `Hmac_sha1 -> hmac_sha1_hash signature_base_string key 149 | | `Rsa_sha1 rsa_key -> rsa_sha1_hash signature_base_string rsa_key 150 | 151 | 152 | 153 | let check_signature 154 | ~http_method ~url 155 | ~oauth_signature_method ~oauth_signature 156 | ~oauth_consumer_key ~oauth_consumer_secret 157 | ?oauth_token ?oauth_token_secret 158 | ~oauth_timestamp ~oauth_nonce ~oauth_version 159 | ?params 160 | () = 161 | 162 | let key = 163 | (rfc3986_encode oauth_consumer_secret ^ "&" ^ 164 | match oauth_token_secret with 165 | | None -> "" 166 | | Some s -> rfc3986_encode s) in 167 | 168 | let signature_base_string = 169 | signature_base_string 170 | ~http_method ~url 171 | ~oauth_signature_method 172 | ~oauth_consumer_key ~oauth_consumer_secret 173 | ?oauth_token ?oauth_token_secret 174 | ~oauth_timestamp ~oauth_nonce ~oauth_version 175 | ?params 176 | () in 177 | 178 | match oauth_signature_method with 179 | | `Plaintext -> rfc3986_encode key = oauth_signature 180 | | `Hmac_sha1 -> hmac_sha1_hash signature_base_string key = oauth_signature 181 | | `Rsa_sha1 rsa_key -> check_rsa_sha1_hash signature_base_string rsa_key oauth_signature 182 | -------------------------------------------------------------------------------- /oauth_netcgi_http.ml: -------------------------------------------------------------------------------- 1 | exception Error of Nethttp.http_status * string 2 | 3 | type request = Netcgi.cgi_activation 4 | 5 | let http_method (cgi : Netcgi.cgi_activation) = 6 | match cgi#request_method with 7 | | `GET -> `Get 8 | | `HEAD -> `Head 9 | | `POST -> `Post 10 | | `DELETE | `PUT _ -> raise (Error (`Method_not_allowed, "")) 11 | 12 | let url (cgi : Netcgi.cgi_activation) = 13 | cgi#url () 14 | 15 | let header (cgi : Netcgi.cgi_activation) h = 16 | cgi#environment#input_header_field h 17 | 18 | let argument (cgi : Netcgi.cgi_activation) ?default a = 19 | try 20 | match cgi#environment#input_content_type_string with 21 | | "application/x-www-form-urlencoded" -> (cgi#argument a)#value 22 | | _ -> List.assoc a (Netencoding.Url.dest_url_encoded_parameters (cgi#environment#cgi_query_string)) 23 | with Not_found as e -> 24 | match default with 25 | | Some d -> d 26 | | None -> raise e 27 | 28 | let arguments (cgi : Netcgi.cgi_activation) = 29 | match cgi#environment#input_content_type_string with 30 | | "application/x-www-form-urlencoded" -> List.map (fun a -> a#name, a#value) cgi#arguments 31 | | _ -> Netencoding.Url.dest_url_encoded_parameters (cgi#environment#cgi_query_string) 32 | 33 | type response = unit 34 | 35 | let respond (cgi : Netcgi.cgi_activation) status fields body = 36 | let fields = List.map (fun (k, v) -> k, [v]) fields in 37 | cgi#set_header ~status ~fields (); 38 | cgi#output#output_string body; 39 | cgi#output#commit_work () 40 | -------------------------------------------------------------------------------- /oauth_netclient_http_client.ml: -------------------------------------------------------------------------------- 1 | let request 2 | ?(http_method = `Post) 3 | ~url 4 | ?(headers = []) 5 | ?(params = []) 6 | ?body 7 | () = 8 | let call = 9 | match http_method, body with 10 | | `Post, None -> 11 | new Http_client.post url params 12 | | `Post, Some (content_type, body) -> 13 | let query = Netencoding.Url.mk_url_encoded_parameters params in 14 | let url = url ^ (if query <> "" then "?" ^ query else "") in 15 | let call = new Http_client.post_raw url body in 16 | (call#request_header `Base)#update_field "Content-type" content_type; 17 | call 18 | | `Get, _ | `Head, _ -> 19 | let query = Netencoding.Url.mk_url_encoded_parameters params in 20 | let url = url ^ (if query <> "" then "?" ^ query else "") in 21 | match http_method with 22 | | `Get -> new Http_client.get url 23 | | `Head -> new Http_client.head url 24 | | `Post -> assert false in 25 | 26 | let h = call#request_header `Base in 27 | List.iter (fun (k,v) -> h#update_field k v) headers; 28 | 29 | let pipeline = new Http_client.pipeline in 30 | (* 31 | pipeline#set_proxy "localhost" 9888; 32 | let url = Neturl.parse_url url in 33 | let host = Neturl.url_host url in 34 | let port = try Neturl.url_port url with Not_found -> 80 in 35 | let url = if port = 80 then host else host ^ ":" ^ string_of_int port in 36 | h#update_field "Host" url; 37 | *) 38 | pipeline#add call; 39 | pipeline#run(); 40 | 41 | (call#response_status, call#response_header#fields, call#response_body#value) 42 | -------------------------------------------------------------------------------- /oauth_ocurl_http_client.ml: -------------------------------------------------------------------------------- 1 | (* Ocamlnet Http_client doesn't support SSL *) 2 | 3 | let request 4 | ?(http_method = `Post) 5 | ~url 6 | ?(headers = []) 7 | ?(params = []) 8 | ?body 9 | () = 10 | let h = Buffer.create 1024 in 11 | let b = Buffer.create 1024 in 12 | 13 | let oc = Curl.init() in 14 | let query = Netencoding.Url.mk_url_encoded_parameters params in 15 | let headers = 16 | match http_method, body with 17 | | `Post, None -> 18 | Curl.set_url oc url; 19 | Curl.set_postfields oc query; 20 | Curl.set_postfieldsize oc (String.length query); 21 | headers 22 | | `Post, Some (content_type, body) -> 23 | let url = url ^ (if query <> "" then "?" ^ query else "") in 24 | Curl.set_url oc url; 25 | Curl.set_postfields oc body; 26 | Curl.set_postfieldsize oc (String.length body); 27 | ("Content-type", content_type)::headers 28 | | `Get, _ | `Head, _ -> 29 | let url = url ^ (if query <> "" then "?" ^ query else "") in 30 | Curl.set_url oc url; 31 | headers in 32 | Curl.set_headerfunction oc (fun s -> Buffer.add_string h s; String.length s); 33 | Curl.set_writefunction oc (fun s -> Buffer.add_string b s; String.length s); 34 | if List.length headers > 0 35 | then begin 36 | let headers = List.map (fun (k, v) -> k ^ ": " ^ v) headers in 37 | Curl.set_httpheader oc headers; 38 | end; 39 | (* 40 | Curl.set_proxy oc "localhost"; 41 | Curl.set_proxyport oc 9888; 42 | Curl.set_sslverifypeer oc false; 43 | *) 44 | Curl.set_transfertext oc true; 45 | Curl.perform oc; 46 | Curl.cleanup oc; 47 | 48 | (* adapted from Ocamlnet http_client.ml *) 49 | try 50 | let line_end_re = Netstring_pcre.regexp "[^\\x00\r\n]+\r?\n" in 51 | let line_end2_re = Netstring_pcre.regexp "([^\\x00\r\n]+\r?\n)*\r?\n" in 52 | let status_re = Netstring_pcre.regexp "^([^ \t]+)[ \t]+([0-9][0-9][0-9])([ \t]+([^\r\n]*))?\r?\n$" in 53 | 54 | let c = Buffer.contents h in 55 | let code, in_pos = 56 | (* Parses the status line. If 1XX: do XXX *) 57 | match Netstring_pcre.string_match line_end_re c 0 with 58 | | None -> raise (Failure "couldn't parse status") 59 | | Some m -> 60 | let s = Netstring_pcre.matched_string m c in 61 | match Netstring_pcre.string_match status_re s 0 with 62 | | None -> raise (Failure "Bad status line") 63 | | Some m -> 64 | let code_str = Netstring_pcre.matched_group m 2 s in 65 | let code = int_of_string code_str in 66 | if code < 100 || code > 599 67 | then raise (Failure "Bad status code") 68 | else Nethttp.http_status_of_int code, Netstring_pcre.match_end m in 69 | 70 | let header = 71 | (* Parses the HTTP header following the status line *) 72 | match Netstring_pcre.string_match line_end2_re c in_pos with 73 | | None -> raise (Failure "couldn't parse header") 74 | | Some m -> 75 | let start = in_pos in 76 | let in_pos = Netstring_pcre.match_end m in 77 | let header_l, _ = 78 | Mimestring.scan_header 79 | ~downcase:false ~unfold:true ~strip:true c 80 | ~start_pos:start ~end_pos:in_pos in 81 | header_l in 82 | 83 | (code, header, Buffer.contents b) 84 | 85 | with Failure msg -> (`Internal_server_error, [], msg) 86 | -------------------------------------------------------------------------------- /oauth_server.ml: -------------------------------------------------------------------------------- 1 | module type Http = 2 | sig 3 | type request 4 | val http_method : request -> [ `Get | `Post | `Head ] 5 | val url : request -> string 6 | val header : request -> string -> string (* throws Not_found *) 7 | val argument : request -> ?default:string -> string -> string (* throws Not_found *) 8 | val arguments : request -> (string * string) list 9 | 10 | type response 11 | val respond : request -> Nethttp.http_status -> (string * string) list -> string -> response 12 | 13 | exception Error of Nethttp.http_status * string 14 | end 15 | 16 | module type Db = 17 | sig 18 | module Http : Http 19 | 20 | type consumer 21 | val lookup_consumer : string -> consumer (* throws Not_found *) 22 | val consumer_key : consumer -> string 23 | val consumer_secret : consumer -> string 24 | val consumer_rsa_key : consumer -> Cryptokit.RSA.key (* throws Not_found *) 25 | 26 | type request_token 27 | val make_request_token : consumer -> Http.request -> request_token 28 | val lookup_request_token: string -> request_token (* throws Not_found *) 29 | val request_token_check_consumer : request_token -> consumer -> bool 30 | val request_token_token : request_token -> string 31 | val request_token_secret : request_token -> string 32 | val request_token_authorized : request_token -> bool 33 | val authorize_request_token : request_token -> Http.request -> unit (* throws Failure *) 34 | 35 | type access_token 36 | val exchange_request_token : request_token -> access_token (* throws Failure *) 37 | val lookup_access_token : string -> access_token (* throws Not_found *) 38 | val access_token_check_consumer : access_token -> consumer -> bool 39 | val access_token_token : access_token -> string 40 | val access_token_secret : access_token -> string 41 | end 42 | 43 | module Make 44 | (Http : Http) 45 | (Db : Db with module Http = Http) = 46 | struct 47 | 48 | let bad_request msg = raise (Http.Error (`Bad_request, msg)) 49 | let unauthorized msg = raise (Http.Error (`Unauthorized, msg)) 50 | 51 | let with_oauth_params req f = 52 | let arg = 53 | try 54 | let h = Http.header req "Authorization" in 55 | let parts = Pcre.split ~pat:"\\s*,\\s*" h in 56 | let args = 57 | List.map 58 | (fun p -> 59 | match Pcre.extract ~pat:"(\\S*)\\s*=\\s*\"([^\"]*)\"" p with 60 | | [| _; k; v |] -> k, Oauth_common.rfc3986_decode v 61 | | _ -> raise Not_found) (* bad header, fall back to CGI args (?) *) 62 | parts in 63 | let arg ?default name = 64 | try List.assoc name args 65 | with Not_found as e -> 66 | match default with 67 | | Some d -> d 68 | | _ -> raise e in 69 | arg 70 | with Not_found -> Http.argument req in 71 | 72 | let required_arg name = 73 | try arg name 74 | with Not_found -> bad_request ("missing parameter " ^ name) in 75 | let optional_arg name = 76 | try Some (arg name) 77 | with Not_found -> None in 78 | 79 | let http_method = Http.http_method req in 80 | let url = Http.url req in 81 | 82 | let oauth_consumer_key = required_arg "oauth_consumer_key" in 83 | let oauth_token = optional_arg "oauth_token" in 84 | let oauth_signature_method = required_arg "oauth_signature_method" in 85 | let oauth_signature = required_arg "oauth_signature" in 86 | let oauth_timestamp = required_arg "oauth_timestamp" in 87 | let oauth_nonce = required_arg "oauth_nonce" in 88 | let oauth_version = arg ~default:"1.0" "oauth_version" in 89 | 90 | if oauth_version <> "1.0" then bad_request ("unsupported version " ^ oauth_version); 91 | 92 | let consumer = 93 | try Db.lookup_consumer oauth_consumer_key 94 | with Not_found -> unauthorized "invalid consumer key" in 95 | let oauth_consumer_secret = Db.consumer_secret consumer in 96 | let oauth_signature_method = 97 | try 98 | Oauth_common.signature_method_of_string 99 | (fun () -> 100 | try Db.consumer_rsa_key consumer 101 | with Not_found -> unauthorized "no RSA key") 102 | oauth_signature_method 103 | with Not_found -> 104 | bad_request ("unsupported signature method " ^ oauth_signature_method) in 105 | let oauth_timestamp = 106 | try float_of_string (oauth_timestamp ^ ".") 107 | with Failure _ -> 0. in 108 | 109 | f 110 | ~http_method ~url ~consumer 111 | ~oauth_consumer_key ~oauth_consumer_secret 112 | ~oauth_signature_method ~oauth_signature 113 | ~oauth_timestamp ~oauth_nonce ~oauth_version 114 | ?oauth_token 115 | () 116 | 117 | 118 | 119 | let fetch_request_token req = 120 | let frt 121 | ~http_method ~url ~consumer 122 | ~oauth_consumer_key ~oauth_consumer_secret 123 | ~oauth_signature_method ~oauth_signature 124 | ~oauth_timestamp ~oauth_nonce ~oauth_version 125 | ?oauth_token 126 | () = 127 | if 128 | Oauth_common.check_signature 129 | ~http_method ~url 130 | ~oauth_signature_method ~oauth_signature 131 | ~oauth_consumer_key ~oauth_consumer_secret 132 | ~oauth_timestamp ~oauth_nonce ~oauth_version 133 | ~params:(Http.arguments req) 134 | () 135 | then 136 | let request_token = Db.make_request_token consumer req in 137 | Http.respond req `Ok [] 138 | (Netencoding.Url.mk_url_encoded_parameters [ 139 | "oauth_token", Db.request_token_token request_token; 140 | "oauth_token_secret", Db.request_token_secret request_token; 141 | ]) 142 | else unauthorized "invalid signature" in 143 | 144 | try with_oauth_params req frt 145 | with Http.Error (status, msg) -> Http.respond req status [] msg 146 | 147 | 148 | 149 | let fetch_access_token req = 150 | let frt 151 | ~http_method ~url ~consumer 152 | ~oauth_consumer_key ~oauth_consumer_secret 153 | ~oauth_signature_method ~oauth_signature 154 | ~oauth_timestamp ~oauth_nonce ~oauth_version 155 | ?oauth_token 156 | () = 157 | let request_token = 158 | match oauth_token with 159 | | None -> bad_request "missing parameter oauth_token" 160 | | Some t -> 161 | try Db.lookup_request_token t 162 | with Not_found -> unauthorized "invalid request token" in 163 | if not (Db.request_token_check_consumer request_token consumer) 164 | then bad_request "consumer/request token mismatch"; 165 | let oauth_token = Db.request_token_token request_token in 166 | let oauth_token_secret = Db.request_token_secret request_token in 167 | if 168 | Oauth_common.check_signature 169 | ~http_method ~url 170 | ~oauth_signature_method ~oauth_signature 171 | ~oauth_consumer_key ~oauth_consumer_secret 172 | ~oauth_token ~oauth_token_secret 173 | ~oauth_timestamp ~oauth_nonce ~oauth_version 174 | ~params:(Http.arguments req) 175 | () 176 | then 177 | let access_token = 178 | try Db.exchange_request_token request_token 179 | with Failure msg -> unauthorized msg in 180 | Http.respond req `Ok [] 181 | (Netencoding.Url.mk_url_encoded_parameters [ 182 | "oauth_token", Db.access_token_token access_token; 183 | "oauth_token_secret", Db.access_token_secret access_token; 184 | ]) 185 | else unauthorized "invalid signature" in 186 | 187 | try with_oauth_params req frt 188 | with Http.Error (status, msg) -> Http.respond req status [] msg 189 | 190 | 191 | 192 | let authorize_request_token req kget kpost = 193 | try 194 | let oauth_token = 195 | try Http.argument req "oauth_token" 196 | with Not_found -> bad_request "missing parameter oauth_token" in 197 | let request_token = 198 | try Db.lookup_request_token oauth_token 199 | with Not_found -> unauthorized "invalid request token" in 200 | if Db.request_token_authorized request_token 201 | then bad_request "request token already authorized"; 202 | 203 | match Http.http_method req with 204 | | `Get -> 205 | kget oauth_token request_token req 206 | | `Post -> 207 | Db.authorize_request_token request_token req; 208 | kpost oauth_token request_token req 209 | | _ -> raise (Http.Error (`Method_not_allowed, "")) 210 | 211 | with Http.Error (status, msg) -> Http.respond req status [] msg 212 | 213 | 214 | 215 | let access_resource req k = 216 | let frt 217 | ~http_method ~url ~consumer 218 | ~oauth_consumer_key ~oauth_consumer_secret 219 | ~oauth_signature_method ~oauth_signature 220 | ~oauth_timestamp ~oauth_nonce ~oauth_version 221 | ?oauth_token 222 | () = 223 | let access_token = 224 | match oauth_token with 225 | | None -> bad_request "missing parameter oauth_token" 226 | | Some t -> 227 | try Db.lookup_access_token t 228 | with Not_found -> unauthorized "invalid access token" in 229 | if not (Db.access_token_check_consumer access_token consumer) 230 | then bad_request "consumer/access token mismatch"; 231 | let oauth_token = Db.access_token_token access_token in 232 | let oauth_token_secret = Db.access_token_secret access_token in 233 | if 234 | Oauth_common.check_signature 235 | ~http_method ~url 236 | ~oauth_signature_method ~oauth_signature 237 | ~oauth_consumer_key ~oauth_consumer_secret 238 | ~oauth_token ~oauth_token_secret 239 | ~oauth_timestamp ~oauth_nonce ~oauth_version 240 | ~params:(Http.arguments req) 241 | () 242 | then k oauth_token access_token req 243 | else unauthorized "invalid signature"in 244 | 245 | try with_oauth_params req frt 246 | with Http.Error (status, msg) -> Http.respond req status [] msg 247 | 248 | end 249 | -------------------------------------------------------------------------------- /oauth_server.mli: -------------------------------------------------------------------------------- 1 | module type Http = 2 | sig 3 | type request 4 | val http_method : request -> [ `Get | `Post | `Head ] 5 | val url : request -> string 6 | val header : request -> string -> string (* throws Not_found *) 7 | val argument : request -> ?default:string -> string -> string (* throws Not_found *) 8 | val arguments : request -> (string * string) list 9 | 10 | type response 11 | val respond : request -> Nethttp.http_status -> (string * string) list -> string -> response 12 | 13 | exception Error of Nethttp.http_status * string 14 | end 15 | 16 | module type Db = 17 | sig 18 | module Http : Http 19 | 20 | type consumer 21 | val lookup_consumer : string -> consumer (* throws Not_found *) 22 | val consumer_key : consumer -> string 23 | val consumer_secret : consumer -> string 24 | val consumer_rsa_key : consumer -> Cryptokit.RSA.key (* throws Not_found *) 25 | 26 | type request_token 27 | val make_request_token : consumer -> Http.request -> request_token 28 | val lookup_request_token: string -> request_token (* throws Not_found *) 29 | val request_token_check_consumer : request_token -> consumer -> bool 30 | val request_token_token : request_token -> string 31 | val request_token_secret : request_token -> string 32 | val request_token_authorized : request_token -> bool 33 | val authorize_request_token : request_token -> Http.request -> unit (* throws Failure *) 34 | 35 | type access_token 36 | val exchange_request_token : request_token -> access_token (* throws Failure *) 37 | val lookup_access_token : string -> access_token (* throws Not_found *) 38 | val access_token_check_consumer : access_token -> consumer -> bool 39 | val access_token_token : access_token -> string 40 | val access_token_secret : access_token -> string 41 | end 42 | 43 | module Make : 44 | functor (Http : Http) -> 45 | functor (Db : Db with module Http = Http) -> 46 | sig 47 | 48 | val fetch_request_token : Http.request -> Http.response 49 | 50 | val fetch_access_token : Http.request -> Http.response 51 | 52 | val authorize_request_token : 53 | Http.request -> 54 | (string -> Db.request_token -> Http.request -> Http.response) -> 55 | (string -> Db.request_token -> Http.request -> Http.response) -> 56 | Http.response 57 | 58 | val access_resource : 59 | Http.request -> 60 | (string -> Db.access_token -> Http.request -> Http.response) -> 61 | Http.response 62 | 63 | end 64 | -------------------------------------------------------------------------------- /oauth_util.ml: -------------------------------------------------------------------------------- 1 | open Oauth_common 2 | 3 | let make_key ?(rng = Cryptokit.Random.device_rng "/dev/random") () = 4 | Cryptokit.Random.string rng 16 |> 5 | Cryptokit.transform_string (Oauth_base32.encode ()) 6 | -------------------------------------------------------------------------------- /ooauth.mllib: -------------------------------------------------------------------------------- 1 | Oauth_base32 2 | Oauth_common 3 | Oauth_client 4 | Oauth_server 5 | Oauth_util 6 | Oauth_ocurl_http_client 7 | Oauth_netclient_http_client 8 | Oauth_netcgi_http 9 | -------------------------------------------------------------------------------- /pem2cryptokit.c: -------------------------------------------------------------------------------- 1 | /* 2 | Converts a private key or certificate in PEM format to a marshaled Cryptokit.RSA.key. 3 | 4 | pem2cryptokit [--certificate] < file.pem > file.ocaml 5 | 6 | Recover the marshaled key with e.g. 7 | 8 | input_value (open_in "file.ocaml") 9 | */ 10 | 11 | #include 12 | #include 13 | 14 | #include 15 | #include 16 | #include 17 | #include 18 | #include 19 | 20 | #include 21 | #include 22 | 23 | CAMLextern void caml_startup_code( 24 | code_t code, asize_t code_size, 25 | char *data, asize_t data_size, 26 | char *section_table, asize_t section_table_size, 27 | char **argv); 28 | 29 | typedef long (*primitive)(); 30 | primitive caml_builtin_cprim[] = { }; 31 | char *caml_names_of_builtin_cprim[] = {}; 32 | char global_data[] = { 33 | /* need to stub out Out_of_memory global for caml_init_exceptions */ 34 | 0x84, 0x95, 0xA6, 0xBE, 0x0, 0x0, 0x0, 0x3, 0x0, 0x0, 0x0, 0x1, 35 | 0x0, 0x0, 0x0, 0x3, 0x0, 0x0, 0x0, 0x3, 0xA0, 0x40, 0x40 36 | }; 37 | 38 | value val_bn(BIGNUM *bn) { 39 | if (bn) { 40 | value v = caml_alloc_string(BN_num_bytes(bn)); 41 | BN_bn2bin(bn, String_val(v)); 42 | return v; 43 | } 44 | else 45 | caml_alloc_string(0); 46 | } 47 | 48 | value val_rsa(RSA *rsa) { 49 | CAMLparam0 (); 50 | CAMLlocal1 (ck_rsa); 51 | ck_rsa = caml_alloc(8, 0); 52 | Store_field(ck_rsa, 0, Val_int(BN_num_bits(rsa->n))); 53 | Store_field(ck_rsa, 1, val_bn(rsa->n)); 54 | Store_field(ck_rsa, 2, val_bn(rsa->e)); 55 | Store_field(ck_rsa, 3, val_bn(rsa->d)); 56 | Store_field(ck_rsa, 4, val_bn(rsa->p)); 57 | Store_field(ck_rsa, 5, val_bn(rsa->q)); 58 | Store_field(ck_rsa, 6, val_bn(rsa->dmp1)); 59 | Store_field(ck_rsa, 7, val_bn(rsa->dmq1)); 60 | Store_field(ck_rsa, 8, val_bn(rsa->iqmp)); 61 | CAMLreturn (ck_rsa); 62 | } 63 | 64 | int main(int argc, char **argv) 65 | { 66 | RSA *rsa = NULL; 67 | EVP_PKEY *pkey = NULL; 68 | X509 *x = NULL; 69 | 70 | caml_startup_code(NULL, 0, global_data, sizeof global_data, NULL, 0, 0); 71 | 72 | if (argc > 1 && strcmp(argv[1], "--certificate") == 0) 73 | { 74 | x = PEM_read_X509_AUX(stdin,NULL,NULL,NULL); 75 | if (x) 76 | pkey = X509_get_pubkey(x); 77 | } 78 | else 79 | pkey = PEM_read_PrivateKey(stdin,NULL,NULL,NULL); 80 | 81 | if (pkey) 82 | rsa = EVP_PKEY_get1_RSA(pkey); 83 | 84 | if (rsa) { 85 | value ck_rsa; 86 | char **buf; 87 | int len; 88 | 89 | ck_rsa = val_rsa(rsa); 90 | caml_output_value_to_malloc(ck_rsa, Val_emptylist, &buf, &len); 91 | write(1, buf, len); 92 | } 93 | else 94 | fprintf(stderr, "Error reading PEM file; check with 'openssl rsa' or 'openssl x509'\n"); 95 | 96 | return 0; 97 | } 98 | --------------------------------------------------------------------------------