From bc83c8de9351ad03428d8f1d8ffafd2ebbe5c7e6 Mon Sep 17 00:00:00 2001 From: Vincent Bernardoff Date: Thu, 8 Aug 2013 17:12:54 +0100 Subject: [PATCH 01/14] Fix compilation on recent ocamlnet, gcc. --- Makefile | 2 +- _tags | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/Makefile b/Makefile index cc5a677..60aa213 100644 --- a/Makefile +++ b/Makefile @@ -15,7 +15,7 @@ all: pem2cryptokit ocamlbuild ooauth.cma ooauth.cmxa pem2cryptokit: pem2cryptokit.c - gcc -g -I$(OCAMLDIR) pem2cryptokit.c -L$(OCAMLDIR) -lssl -lcrypto -lcamlrun -lm -o pem2cryptokit + gcc -g -I$(OCAMLDIR) pem2cryptokit.c -L$(OCAMLDIR) -lssl -lcrypto -lcamlrun -lm -ldl -o pem2cryptokit install: all ocamlfind install ooauth META $(BFILES) diff --git a/_tags b/_tags index 4003222..17ad6d8 100644 --- a/_tags +++ b/_tags @@ -1,4 +1,4 @@ -<*.ml*> : debug,pkg_cryptokit,pkg_netstring +<*.ml*> : debug,pkg_cryptokit,pkg_netstring-pcre,pkg_pcre,pkg_nethttpd : pkg_curl : pkg_netclient - : pkg_netcgi2 + : pkg_netcgi From f0277bc41227953343b74ca94071dd3f4547b7eb Mon Sep 17 00:00:00 2001 From: Vincent Bernardoff Date: Fri, 9 Aug 2013 14:42:35 +0100 Subject: [PATCH 02/14] Now works fine on my system. --- .gitignore | 5 ++ META | 2 +- Makefile | 11 +--- README | 16 ----- README.md | 19 ++++++ _tags | 8 +-- examples/localhost/Makefile | 13 ++-- examples/localhost/_tags | 8 +-- examples/localhost/client.ml | 2 +- examples/localhost/myocamlbuild.ml | 45 -------------- examples/localhost/server.ml | 10 +-- examples/term.ie/Makefile | 8 +-- examples/term.ie/_tags | 5 +- examples/term.ie/client.ml | 81 +++++++++++++++---------- examples/term.ie/myocamlbuild.ml | 45 -------------- myocamlbuild.ml | 45 -------------- pem2cryptokit.c | 97 ------------------------------ 17 files changed, 103 insertions(+), 317 deletions(-) create mode 100644 .gitignore delete mode 100644 README create mode 100644 README.md delete mode 100644 examples/localhost/myocamlbuild.ml delete mode 100644 examples/term.ie/myocamlbuild.ml delete mode 100644 myocamlbuild.ml delete mode 100644 pem2cryptokit.c diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..9b825a4 --- /dev/null +++ b/.gitignore @@ -0,0 +1,5 @@ +**/_build +**/public_key.pem +**/*.byte +**/*.native + diff --git a/META b/META index 33ab646..5f0b795 100644 --- a/META +++ b/META @@ -1,6 +1,6 @@ name="OOAuth" version="0.1" description="OAuth implementation" -requires="cryptokit,netstring,ocurl,netclient" +requires="pcre, cryptokit, netstring, netstring-pcre, curl, netclient" archive(byte) = "ooauth.cma" archive(native) = "ooauth.cmxa" diff --git a/Makefile b/Makefile index 60aa213..73fbeaf 100644 --- a/Makefile +++ b/Makefile @@ -1,4 +1,4 @@ -OCAMLDIR=`ocamlfind printconf stdlib` +PREFIX=/usr/local FILES=\ ooauth.cma ooauth.cmxa ooauth.a \ oauth_client.mli oauth_client.cmi \ @@ -11,22 +11,17 @@ oauth_netcgi_http.cmi BFILES=$(addprefix _build/,$(FILES)) -all: pem2cryptokit - ocamlbuild ooauth.cma ooauth.cmxa - -pem2cryptokit: pem2cryptokit.c - gcc -g -I$(OCAMLDIR) pem2cryptokit.c -L$(OCAMLDIR) -lssl -lcrypto -lcamlrun -lm -ldl -o pem2cryptokit +all: + ocamlbuild -use-ocamlfind ooauth.cma ooauth.cmxa install: all ocamlfind install ooauth META $(BFILES) - cp pem2cryptokit $(OCAMLDIR)/../../bin uninstall: ocamlfind remove ooauth clean: ocamlbuild -clean - rm -f pem2cryptokit $(MAKE) -C examples clean dist: clean diff --git a/README b/README deleted file mode 100644 index cf02e69..0000000 --- a/README +++ /dev/null @@ -1,16 +0,0 @@ -This is OOAuth, OAuth for OCaml, version 0.1. - -Requirements: - - Cryptokit, Ocamlnet, Ocurl is optional. - -To configure: - - If you don't have Ocurl, remove references to it from ooauth.mllib, META, and FILES in Makefile. - -To install: - - make - make install - -After installing, try the example in examples/term.ie/. diff --git a/README.md b/README.md new file mode 100644 index 0000000..cc327bb --- /dev/null +++ b/README.md @@ -0,0 +1,19 @@ +# This is OOAuth, OAuth for OCaml, version 0.1. + +## Requirements: + +- cryptokit +- ocamlnet +- ocaml-crypto-keys (https://github.com/crotsos/ocaml-crypto-keys) +- ocurl (optional) + +## To configure: + +If you don't have Ocurl, remove references to it from ooauth.mllib, META, and FILES in Makefile. + +## To install: + +* make +* make install + +After installing, try the example in examples/term.ie/. diff --git a/_tags b/_tags index 17ad6d8..2d72079 100644 --- a/_tags +++ b/_tags @@ -1,4 +1,4 @@ -<*.ml*> : debug,pkg_cryptokit,pkg_netstring-pcre,pkg_pcre,pkg_nethttpd - : pkg_curl - : pkg_netclient - : pkg_netcgi +<*.ml*> : debug, package(cryptokit), package(netstring-pcre), package(pcre), package(nethttpd) + : package(curl) + : package(netclient) + : package(netcgi2) diff --git a/examples/localhost/Makefile b/examples/localhost/Makefile index 5a52f11..f789f9a 100644 --- a/examples/localhost/Makefile +++ b/examples/localhost/Makefile @@ -1,12 +1,11 @@ -all: private_key.ocaml certificate.ocaml - ocamlbuild client.byte server.byte +.PHONY: all -private_key.ocaml: private_key.pem - pem2cryptokit < private_key.pem > private_key.ocaml +all: public_key.pem + ocamlbuild -use-ocamlfind client.byte server.byte -certificate.ocaml: certificate.pem - pem2cryptokit --certificate < certificate.pem > certificate.ocaml +public_key.pem: certificate.pem + openssl x509 -in certificate.pem -pubkey -noout > public_key.pem clean: ocamlbuild -clean - rm -f private_key.ocaml certificate.ocaml + rm -f public_key.pem diff --git a/examples/localhost/_tags b/examples/localhost/_tags index 76177f2..30a3d64 100644 --- a/examples/localhost/_tags +++ b/examples/localhost/_tags @@ -1,4 +1,4 @@ -<*.ml*> : debug,pkg_ooauth -<*.byte> : debug,pkg_ooauth - : pkg_netplex,pkg_nethttpd - : pkg_netplex,pkg_nethttpd +<*.ml*> : debug, package(ooauth), package(crypto_keys) +<*.byte> : debug, package(ooauth), package(crypto_keys) + : package(netplex), package(nethttpd), package(pcre) +<*.byte> : package(netplex), package(nethttpd), package(pcre), package(crypto_keys) diff --git a/examples/localhost/client.ml b/examples/localhost/client.ml index 4d3f021..653e79c 100644 --- a/examples/localhost/client.ml +++ b/examples/localhost/client.ml @@ -8,7 +8,7 @@ *) module OC = Oauth_client.Make(Oauth_netclient_http_client) -let rsa_key = input_value (open_in "private_key.ocaml") +let rsa_key = Rsa.read_rsa_privkey "private_key.pem" let oauth_signature_method = `Rsa_sha1 rsa_key let http_method = `Post diff --git a/examples/localhost/myocamlbuild.ml b/examples/localhost/myocamlbuild.ml deleted file mode 100644 index 833ec86..0000000 --- a/examples/localhost/myocamlbuild.ml +++ /dev/null @@ -1,45 +0,0 @@ -open Ocamlbuild_plugin - -(* ocamlfind integration following http://www.nabble.com/forum/ViewPost.jtp?post=15979274 *) - -(* these functions are not really officially exported *) -let run_and_read = Ocamlbuild_pack.My_unix.run_and_read -let blank_sep_strings = Ocamlbuild_pack.Lexers.blank_sep_strings - -(* this lists all supported packages *) -let find_packages () = - blank_sep_strings & - Lexing.from_string & - run_and_read "ocamlfind list | cut -d' ' -f1" - -(* ocamlfind command *) -let ocamlfind x = S[A"ocamlfind"; x] - -;; - -dispatch begin function - | Before_options -> - - (* override default commands by ocamlfind ones *) - Options.ocamlc := ocamlfind & A"ocamlc"; - Options.ocamlopt := ocamlfind & A"ocamlopt"; - Options.ocamldep := ocamlfind & A"ocamldep"; - Options.ocamldoc := ocamlfind & A"ocamldoc" - - | After_rules -> - - (* When one link an OCaml library/binary/package, one should use -linkpkg *) - flag ["ocaml"; "link"] & A"-linkpkg"; - - (* For each ocamlfind package one inject the -package option when - * compiling, computing dependencies, generating documentation and - * linking. *) - List.iter begin fun pkg -> - flag ["ocaml"; "compile"; "pkg_"^pkg] & S[A"-package"; A pkg]; - flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S[A"-package"; A pkg]; - flag ["ocaml"; "doc"; "pkg_"^pkg] & S[A"-package"; A pkg]; - flag ["ocaml"; "link"; "pkg_"^pkg] & S[A"-package"; A pkg]; - end (find_packages ()); - - | _ -> () -end diff --git a/examples/localhost/server.ml b/examples/localhost/server.ml index 02c86a3..ea4beeb 100644 --- a/examples/localhost/server.ml +++ b/examples/localhost/server.ml @@ -4,7 +4,7 @@ struct module Http = Oauth_netcgi_http type consumer = string * string * Cryptokit.RSA.key - let consumers = ["key", "secret", input_value (open_in "certificate.ocaml") ] + let consumers = ["key", "secret", Rsa.read_rsa_pubkey "public_key.pem" ] let lookup_consumer k = List.find (fun (k',_,_) -> k' = k) consumers let consumer_key (k,_,_) = k let consumer_secret (_,s,_) = s @@ -41,7 +41,7 @@ end module OS = Oauth_server.Make(Oauth_netcgi_http)(Db) -let authorize_get oauth_token request_token (cgi : Netcgi_types.cgi_activation) = +let authorize_get oauth_token request_token (cgi : Netcgi.cgi_activation) = Oauth_netcgi_http.respond cgi `Ok [] (Printf.sprintf " @@ -60,7 +60,7 @@ let authorize_get oauth_token request_token (cgi : Netcgi_types.cgi_activation) oauth_token (cgi#argument_value "oauth_callback")) -let authorize_post oauth_token request_token (cgi : Netcgi_types.cgi_activation) = +let authorize_post oauth_token request_token (cgi : Netcgi.cgi_activation) = let oauth_callback = cgi#argument_value "oauth_callback" in match oauth_callback with | "" -> Oauth_netcgi_http.respond cgi `Ok [] @@ -74,10 +74,10 @@ let authorize_post oauth_token request_token (cgi : Netcgi_types.cgi_activation) " | _ -> Oauth_netcgi_http.respond cgi `Found ["Location", oauth_callback] "" -let echo oauth_token access_token (cgi : Netcgi_types.cgi_activation) = +let echo oauth_token access_token (cgi : Netcgi.cgi_activation) = Oauth_netcgi_http.respond cgi `Ok [] (Netencoding.Url.mk_url_encoded_parameters (Oauth_netcgi_http.arguments cgi)) -let oauth_cgi_handler (cgi : Netcgi_types.cgi_activation) = +let oauth_cgi_handler (cgi : Netcgi.cgi_activation) = let url = cgi#url ~with_authority:`None () in match Neturl.split_path url with | [ _; "request_token" ] -> OS.fetch_request_token cgi diff --git a/examples/term.ie/Makefile b/examples/term.ie/Makefile index a781091..c3686f8 100644 --- a/examples/term.ie/Makefile +++ b/examples/term.ie/Makefile @@ -1,9 +1,5 @@ -all: private_key.ocaml - ocamlbuild client.byte - -private_key.ocaml: private_key.pem - pem2cryptokit < private_key.pem > private_key.ocaml +all: + ocamlbuild -use-ocamlfind client.byte clean: ocamlbuild -clean - rm -f private_key.ocaml diff --git a/examples/term.ie/_tags b/examples/term.ie/_tags index 0de45cd..cb50ea5 100644 --- a/examples/term.ie/_tags +++ b/examples/term.ie/_tags @@ -1,2 +1,3 @@ -<*.ml*> : debug,pkg_ooauth -<*.byte> : debug,pkg_ooauth +<*.ml*>: debug, package(ooauth), package(crypto_keys) +<*.byte>: debug, package(ooauth), package(crypto_keys) +true: annot diff --git a/examples/term.ie/client.ml b/examples/term.ie/client.ml index 7d4d158..d70cde1 100644 --- a/examples/term.ie/client.ml +++ b/examples/term.ie/client.ml @@ -2,39 +2,58 @@ module OC = Oauth_client.Make(Oauth_netclient_http_client) -let rsa_key = input_value (open_in "private_key.ocaml") +let rsa_key = Rsa.read_rsa_privkey "private_key.pem" + +(* from http://term.ie/oauth/example *) +let oauth_consumer_key = "key" +let oauth_consumer_secret = "secret" + let oauth_signature_method = `Rsa_sha1 rsa_key let http_method = `Post - let url s = "http://term.ie/oauth/example" ^ s -;; - -let (oauth_token, oauth_token_secret) = - OC.fetch_request_token - ~http_method ~url:(url "/request_token.php") - ~oauth_signature_method - ~oauth_consumer_key:"key" ~oauth_consumer_secret:"secret" - () in -prerr_endline ("oauth_token = " ^ oauth_token); -prerr_endline ("oauth_token_secret = " ^ oauth_token_secret); - -let (oauth_token, oauth_token_secret) = - OC.fetch_access_token - ~http_method ~url:(url "/access_token.php") - ~oauth_signature_method - ~oauth_consumer_key:"key" ~oauth_consumer_secret:"secret" - ~oauth_token ~oauth_token_secret +let fetch_request_token () = + let oauth_token, oauth_token_secret = + OC.fetch_request_token + ~http_method + ~url:(url "/request_token.php") + ~oauth_signature_method + ~oauth_consumer_key + ~oauth_consumer_secret + () in + prerr_endline ("oauth_token = " ^ oauth_token); + prerr_endline ("oauth_token_secret = " ^ oauth_token_secret); + oauth_token, oauth_token_secret + +let fetch_access_token oauth_token oauth_token_secret = + let oauth_token, oauth_token_secret = + OC.fetch_access_token + ~http_method + ~url:(url "/access_token.php") + ~oauth_signature_method + ~oauth_consumer_key + ~oauth_consumer_secret + ~oauth_token + ~oauth_token_secret + () in + prerr_endline ("oauth_token = " ^ oauth_token); + prerr_endline ("oauth_token_secret = " ^ oauth_token_secret); + oauth_token, oauth_token_secret + +let access_resource oauth_token oauth_token_secret = + let res = + OC.access_resource + ~http_method ~url:(url "/echo_api.php") + ~oauth_signature_method + ~oauth_consumer_key + ~oauth_consumer_secret + ~oauth_token + ~oauth_token_secret + ~params:["method", "foo"; "bar", "baz"] () in -prerr_endline ("oauth_token = " ^ oauth_token); -prerr_endline ("oauth_token_secret = " ^ oauth_token_secret); - -let res = - OC.access_resource - ~http_method ~url:(url "/echo_api.php") - ~oauth_signature_method - ~oauth_consumer_key:"key" ~oauth_consumer_secret:"secret" - ~oauth_token ~oauth_token_secret - ~params:["method", "foo"; "bar", "baz"] - () in -prerr_endline ("res = " ^ res); + prerr_endline ("res = " ^ res) + +let _ = + let t, st = fetch_request_token () in + let t, st = fetch_access_token t st in + access_resource t st diff --git a/examples/term.ie/myocamlbuild.ml b/examples/term.ie/myocamlbuild.ml deleted file mode 100644 index 833ec86..0000000 --- a/examples/term.ie/myocamlbuild.ml +++ /dev/null @@ -1,45 +0,0 @@ -open Ocamlbuild_plugin - -(* ocamlfind integration following http://www.nabble.com/forum/ViewPost.jtp?post=15979274 *) - -(* these functions are not really officially exported *) -let run_and_read = Ocamlbuild_pack.My_unix.run_and_read -let blank_sep_strings = Ocamlbuild_pack.Lexers.blank_sep_strings - -(* this lists all supported packages *) -let find_packages () = - blank_sep_strings & - Lexing.from_string & - run_and_read "ocamlfind list | cut -d' ' -f1" - -(* ocamlfind command *) -let ocamlfind x = S[A"ocamlfind"; x] - -;; - -dispatch begin function - | Before_options -> - - (* override default commands by ocamlfind ones *) - Options.ocamlc := ocamlfind & A"ocamlc"; - Options.ocamlopt := ocamlfind & A"ocamlopt"; - Options.ocamldep := ocamlfind & A"ocamldep"; - Options.ocamldoc := ocamlfind & A"ocamldoc" - - | After_rules -> - - (* When one link an OCaml library/binary/package, one should use -linkpkg *) - flag ["ocaml"; "link"] & A"-linkpkg"; - - (* For each ocamlfind package one inject the -package option when - * compiling, computing dependencies, generating documentation and - * linking. *) - List.iter begin fun pkg -> - flag ["ocaml"; "compile"; "pkg_"^pkg] & S[A"-package"; A pkg]; - flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S[A"-package"; A pkg]; - flag ["ocaml"; "doc"; "pkg_"^pkg] & S[A"-package"; A pkg]; - flag ["ocaml"; "link"; "pkg_"^pkg] & S[A"-package"; A pkg]; - end (find_packages ()); - - | _ -> () -end diff --git a/myocamlbuild.ml b/myocamlbuild.ml deleted file mode 100644 index 833ec86..0000000 --- a/myocamlbuild.ml +++ /dev/null @@ -1,45 +0,0 @@ -open Ocamlbuild_plugin - -(* ocamlfind integration following http://www.nabble.com/forum/ViewPost.jtp?post=15979274 *) - -(* these functions are not really officially exported *) -let run_and_read = Ocamlbuild_pack.My_unix.run_and_read -let blank_sep_strings = Ocamlbuild_pack.Lexers.blank_sep_strings - -(* this lists all supported packages *) -let find_packages () = - blank_sep_strings & - Lexing.from_string & - run_and_read "ocamlfind list | cut -d' ' -f1" - -(* ocamlfind command *) -let ocamlfind x = S[A"ocamlfind"; x] - -;; - -dispatch begin function - | Before_options -> - - (* override default commands by ocamlfind ones *) - Options.ocamlc := ocamlfind & A"ocamlc"; - Options.ocamlopt := ocamlfind & A"ocamlopt"; - Options.ocamldep := ocamlfind & A"ocamldep"; - Options.ocamldoc := ocamlfind & A"ocamldoc" - - | After_rules -> - - (* When one link an OCaml library/binary/package, one should use -linkpkg *) - flag ["ocaml"; "link"] & A"-linkpkg"; - - (* For each ocamlfind package one inject the -package option when - * compiling, computing dependencies, generating documentation and - * linking. *) - List.iter begin fun pkg -> - flag ["ocaml"; "compile"; "pkg_"^pkg] & S[A"-package"; A pkg]; - flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S[A"-package"; A pkg]; - flag ["ocaml"; "doc"; "pkg_"^pkg] & S[A"-package"; A pkg]; - flag ["ocaml"; "link"; "pkg_"^pkg] & S[A"-package"; A pkg]; - end (find_packages ()); - - | _ -> () -end diff --git a/pem2cryptokit.c b/pem2cryptokit.c deleted file mode 100644 index 31a980c..0000000 --- a/pem2cryptokit.c +++ /dev/null @@ -1,97 +0,0 @@ -/* - Converts a private key or certificate in PEM format to a marshaled Cryptokit.RSA.key. - - pem2cryptokit [--certificate] < file.pem > file.ocaml - - Recover the marshaled key with e.g. - - input_value (open_in "file.ocaml") -*/ - -#include -#include - -#include -#include -#include -#include -#include - -#include -#include - -CAMLextern void caml_startup_code( - code_t code, asize_t code_size, - char *data, asize_t data_size, - char *section_table, asize_t section_table_size, - char **argv); - -typedef long (*primitive)(); -primitive caml_builtin_cprim[] = { }; -char *caml_names_of_builtin_cprim[] = {}; -char global_data[] = { - /* need to stub out Out_of_memory global for caml_init_exceptions */ - 0x84, 0x95, 0xA6, 0xBE, 0x0, 0x0, 0x0, 0x3, 0x0, 0x0, 0x0, 0x1, - 0x0, 0x0, 0x0, 0x3, 0x0, 0x0, 0x0, 0x3, 0xA0, 0x40, 0x40 -}; - -value val_bn(BIGNUM *bn) { - if (bn) { - value v = caml_alloc_string(BN_num_bytes(bn)); - BN_bn2bin(bn, String_val(v)); - return v; - } - else - caml_alloc_string(0); -} - -value val_rsa(RSA *rsa) { - CAMLparam0 (); - CAMLlocal1 (ck_rsa); - ck_rsa = caml_alloc(8, 0); - Store_field(ck_rsa, 0, Val_int(BN_num_bits(rsa->n))); - Store_field(ck_rsa, 1, val_bn(rsa->n)); - Store_field(ck_rsa, 2, val_bn(rsa->e)); - Store_field(ck_rsa, 3, val_bn(rsa->d)); - Store_field(ck_rsa, 4, val_bn(rsa->p)); - Store_field(ck_rsa, 5, val_bn(rsa->q)); - Store_field(ck_rsa, 6, val_bn(rsa->dmp1)); - Store_field(ck_rsa, 7, val_bn(rsa->dmq1)); - Store_field(ck_rsa, 8, val_bn(rsa->iqmp)); - CAMLreturn (ck_rsa); -} - -int main(int argc, char **argv) -{ - RSA *rsa = NULL; - EVP_PKEY *pkey = NULL; - X509 *x = NULL; - - caml_startup_code(NULL, 0, global_data, sizeof global_data, NULL, 0, 0); - - if (argc > 1 && strcmp(argv[1], "--certificate") == 0) - { - x = PEM_read_X509_AUX(stdin,NULL,NULL,NULL); - if (x) - pkey = X509_get_pubkey(x); - } - else - pkey = PEM_read_PrivateKey(stdin,NULL,NULL,NULL); - - if (pkey) - rsa = EVP_PKEY_get1_RSA(pkey); - - if (rsa) { - value ck_rsa; - char **buf; - int len; - - ck_rsa = val_rsa(rsa); - caml_output_value_to_malloc(ck_rsa, Val_emptylist, &buf, &len); - write(1, buf, len); - } - else - fprintf(stderr, "Error reading PEM file; check with 'openssl rsa' or 'openssl x509'\n"); - - return 0; -} From c2dec3f1d577c75d80554e8ba4ea729d82c78a1f Mon Sep 17 00:00:00 2001 From: Vincent Bernardoff Date: Fri, 9 Aug 2013 15:58:30 +0100 Subject: [PATCH 03/14] Removed pcre as a (direct) dependency in _tags. --- _tags | 2 +- examples/localhost/_tags | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/_tags b/_tags index 2d72079..8435306 100644 --- a/_tags +++ b/_tags @@ -1,4 +1,4 @@ -<*.ml*> : debug, package(cryptokit), package(netstring-pcre), package(pcre), package(nethttpd) +<*.ml*> : debug, package(cryptokit), package(netstring-pcre), package(nethttpd) : package(curl) : package(netclient) : package(netcgi2) diff --git a/examples/localhost/_tags b/examples/localhost/_tags index 30a3d64..07c4288 100644 --- a/examples/localhost/_tags +++ b/examples/localhost/_tags @@ -1,4 +1,4 @@ <*.ml*> : debug, package(ooauth), package(crypto_keys) <*.byte> : debug, package(ooauth), package(crypto_keys) - : package(netplex), package(nethttpd), package(pcre) -<*.byte> : package(netplex), package(nethttpd), package(pcre), package(crypto_keys) + : package(netplex), package(nethttpd) +<*.byte> : package(netplex), package(nethttpd), package(crypto_keys) From 164aaadfd948bdd3d5c054c07a2f79df828eaccd Mon Sep 17 00:00:00 2001 From: Vincent Bernardoff Date: Thu, 3 Oct 2013 17:25:44 +0200 Subject: [PATCH 04/14] Added cohttp backend for client and server, removed unfriendly dependencies. --- Makefile | 8 +-- _tags | 4 +- oauth_client.ml | 104 +++++++++++++++++++++++++----------- oauth_client.mli | 69 ++++++++++++++++++++---- oauth_cohttp_http.ml | 38 +++++++++++++ oauth_cohttp_http_client.ml | 36 +++++++++++++ oauth_common.ml | 17 +++--- oauth_ocurl_http_client.ml | 78 +++++++++++++++++++++++---- oauth_server.ml | 81 ++++++++++++++++++++++------ oauth_server.mli | 75 +++++++++++++++++++++----- ooauth.mllib | 8 +-- 11 files changed, 424 insertions(+), 94 deletions(-) create mode 100644 oauth_cohttp_http.ml create mode 100644 oauth_cohttp_http_client.ml diff --git a/Makefile b/Makefile index 73fbeaf..37db4c6 100644 --- a/Makefile +++ b/Makefile @@ -4,10 +4,10 @@ ooauth.cma ooauth.cmxa ooauth.a \ oauth_client.mli oauth_client.cmi \ oauth_server.mli oauth_server.cmi \ oauth_base32.mli oauth_base32.cmi \ -oauth_util.cmi \ -oauth_ocurl_http_client.cmi \ -oauth_netclient_http_client.cmi \ -oauth_netcgi_http.cmi +oauth_util.cmi +#oauth_ocurl_http_client.cmi \ +#oauth_netclient_http_client.cmi \ +#oauth_netcgi_http.cmi BFILES=$(addprefix _build/,$(FILES)) diff --git a/_tags b/_tags index 8435306..30486a0 100644 --- a/_tags +++ b/_tags @@ -1,4 +1,6 @@ -<*.ml*> : debug, package(cryptokit), package(netstring-pcre), package(nethttpd) +<*.ml*> : debug, package(cryptokit), package(uri) + : package(cohttp.lwt) + : package(cohttp.lwt) : package(curl) : package(netclient) : package(netcgi2) diff --git a/oauth_client.ml b/oauth_client.ml index 6e81017..d92a0fd 100644 --- a/oauth_client.ml +++ b/oauth_client.ml @@ -1,19 +1,72 @@ module type Http_client = sig + module Monad : sig + type 'a t + val return : 'a -> 'a t + val fail : exn -> 'a t + val (>>=) : 'a t -> ('a -> 'b t) -> 'b t + val (>|=) : 'a t -> ('a -> 'b) -> 'b t + end + + type status = + [ `Accepted + | `Bad_gateway + | `Bad_request + | `Conflict + | `Continue + | `Created + | `Expectation_failed + | `Forbidden + | `Found + | `Gateway_time_out + | `Gone + | `HTTP_version_not_supported + | `Internal_server_error + | `Length_required + | `Method_not_allowed + | `Moved_permanently + | `Multiple_choices + | `No_content + | `Non_authoritative_information + | `Not_acceptable + | `Not_found + | `Not_implemented + | `Not_modified + | `OK + | `Partial_content + | `Payment_required + | `Precondition_failed + | `Proxy_authentication_required + | `Request_URI_too_large + | `Request_entity_too_large + | `Request_time_out + | `Requested_range_not_satisfiable + | `Reset_content + | `See_other + | `Service_unavailable + | `Switching_protocols + | `Temporary_redirect + | `Unauthorized + | `Unprocessable_entity + | `Unsupported_media_type + | `Use_proxy ] + val request : - ?http_method:[ `Get | `Head | `Post ] -> + ?http_method:[ `GET | `HEAD | `POST ] -> url:string -> ?headers:(string * string) list -> ?params:(string * string) list -> ?body:string * string -> (* content type * body *) unit -> - Nethttp.http_status * (string * string) list * string + (status * (string * string) list * string) Monad.t end module Make (Http_client : Http_client) = struct - exception Error of Nethttp.http_status * string + open Http_client.Monad + + exception Error of Http_client.status * string open Oauth_common @@ -45,7 +98,7 @@ struct let parse_response res = try - let params = Netencoding.Url.dest_url_encoded_parameters res in + let params = Uri.query_of_encoded res |> List.map (fun (k,vs) -> k,List.hd vs) in (List.assoc "oauth_token" params, List.assoc "oauth_token_secret" params) with | _ -> raise (Error (`Internal_server_error, "bad response: " ^ res)) @@ -53,7 +106,7 @@ struct let fetch_request_token - ?(http_method = `Post) ~url + ?(http_method = `POST) ~url ?(oauth_version = "1.0") ?(oauth_signature_method = `Hmac_sha1) ~oauth_consumer_key ~oauth_consumer_secret ?(oauth_timestamp = make_timestamp ()) ?(oauth_nonce = make_nonce ()) @@ -76,22 +129,19 @@ struct ~oauth_timestamp ~oauth_nonce () :: headers in - let res = - Http_client.request - ~http_method - ~url - ~headers - ?params - () in - - match res with - | (`Ok, _, res) -> parse_response res - | (status, _, res) -> raise (Error (status, res)) + Http_client.request + ~http_method + ~url + ~headers + ?params + () >>= function + | (`OK, _, res) -> return (parse_response res) + | (status, _, res) -> fail (Error (status, res)) let fetch_access_token - ?(http_method = `Post) ~url + ?(http_method = `POST) ~url ?(oauth_version = "1.0") ?(oauth_signature_method = `Hmac_sha1) ~oauth_consumer_key ~oauth_consumer_secret ~oauth_token ~oauth_token_secret @@ -115,21 +165,18 @@ struct ~oauth_timestamp ~oauth_nonce () :: headers in - let res = Http_client.request ~http_method ~url ~headers - () in - - match res with - | (`Ok, _, res) -> parse_response res - | (status, _, res) -> raise (Error (status, res)) + () >>= function + | (`OK, _, res) -> return (parse_response res) + | (status, _, res) -> fail (Error (status, res)) let access_resource - ?(http_method = `Post) ~url + ?(http_method = `POST) ~url ?(oauth_version = "1.0") ?(oauth_signature_method = `Hmac_sha1) ~oauth_consumer_key ~oauth_consumer_secret ~oauth_token ~oauth_token_secret @@ -154,17 +201,14 @@ struct ~oauth_timestamp ~oauth_nonce () :: headers in - let res = Http_client.request ~http_method ~url ~headers ?params ?body - () in - - match res with - | (`Ok, _, res) -> res - | (status, _, res) -> raise (Error (status, res)) + () >>= function + | (`OK, _, res) -> return res + | (status, _, res) -> fail (Error (status, res)) end diff --git a/oauth_client.mli b/oauth_client.mli index 240ab7e..37ba84e 100644 --- a/oauth_client.mli +++ b/oauth_client.mli @@ -1,22 +1,73 @@ module type Http_client = sig + module Monad : sig + type 'a t + val return : 'a -> 'a t + val fail : exn -> 'a t + val (>>=) : 'a t -> ('a -> 'b t) -> 'b t + val (>|=) : 'a t -> ('a -> 'b) -> 'b t + end + + type status = + [ `Accepted + | `Bad_gateway + | `Bad_request + | `Conflict + | `Continue + | `Created + | `Expectation_failed + | `Forbidden + | `Found + | `Gateway_time_out + | `Gone + | `HTTP_version_not_supported + | `Internal_server_error + | `Length_required + | `Method_not_allowed + | `Moved_permanently + | `Multiple_choices + | `No_content + | `Non_authoritative_information + | `Not_acceptable + | `Not_found + | `Not_implemented + | `Not_modified + | `OK + | `Partial_content + | `Payment_required + | `Precondition_failed + | `Proxy_authentication_required + | `Request_URI_too_large + | `Request_entity_too_large + | `Request_time_out + | `Requested_range_not_satisfiable + | `Reset_content + | `See_other + | `Service_unavailable + | `Switching_protocols + | `Temporary_redirect + | `Unauthorized + | `Unprocessable_entity + | `Unsupported_media_type + | `Use_proxy ] + val request : - ?http_method:[ `Get | `Head | `Post ] -> + ?http_method:[ `GET | `HEAD | `POST ] -> url:string -> ?headers:(string * string) list -> ?params:(string * string) list -> ?body:string * string -> (* content type * body *) unit -> - Nethttp.http_status * (string * string) list * string + (status * (string * string) list * string) Monad.t end module Make : functor (Http_client : Http_client) -> sig - exception Error of Nethttp.http_status * string + exception Error of Http_client.status * string val fetch_request_token : - ?http_method:[ `Get | `Head | `Post ] -> + ?http_method:[ `GET | `HEAD | `POST ] -> url:string -> ?oauth_version:string -> ?oauth_signature_method:[ `Plaintext | `Hmac_sha1 | `Rsa_sha1 of Cryptokit.RSA.key ] -> @@ -27,10 +78,10 @@ sig ?params:(string * string) list -> ?headers:(string * string) list -> unit -> - string * string + (string * string) Http_client.Monad.t val fetch_access_token : - ?http_method:[ `Get | `Head | `Post ] -> + ?http_method:[ `GET | `HEAD | `POST ] -> url:string -> ?oauth_version:string -> ?oauth_signature_method:[ `Plaintext | `Hmac_sha1 | `Rsa_sha1 of Cryptokit.RSA.key ] -> @@ -42,10 +93,10 @@ sig ?oauth_nonce:string -> ?headers:(string * string) list -> unit -> - string * string + (string * string) Http_client.Monad.t val access_resource : - ?http_method:[ `Get | `Head | `Post ] -> + ?http_method:[ `GET | `HEAD | `POST ] -> url:string -> ?oauth_version:string -> ?oauth_signature_method:[ `Plaintext | `Hmac_sha1 | `Rsa_sha1 of Cryptokit.RSA.key ] -> @@ -59,6 +110,6 @@ sig ?headers:(string * string) list -> ?body:string * string -> (* content type * body *) unit -> - string + string Http_client.Monad.t end diff --git a/oauth_cohttp_http.ml b/oauth_cohttp_http.ml new file mode 100644 index 0000000..81decba --- /dev/null +++ b/oauth_cohttp_http.ml @@ -0,0 +1,38 @@ +module C = Cohttp +module CU = Cohttp_lwt_unix +module CB = Cohttp_lwt_body + +let (>>=) = Lwt.bind + +module Monad = Lwt + +type status = C.Code.status + +type request = CU.Server.Request.t + +let http_method = CU.Request.meth + +let url req = Uri.to_string (CU.Request.uri req) + +let header req h = + let hs = CU.Request.headers req in + match C.Header.get hs h with + | Some h -> h + | None -> raise Not_found + +let argument req ?default arg = + let uri = CU.Request.uri req in + match default, Uri.get_query_param uri arg with + | _, Some v -> v + | Some d, None -> d + | _ -> raise Not_found + +let arguments req = + let uri = CU.Request.uri req in + List.map (fun (k,vs) -> (k, List.hd vs)) (Uri.query uri) + +type response = (CU.Response.t * Cohttp_lwt_body.t) + +let respond req status headers body = + let headers = C.Header.of_list headers in + CU.Server.respond_string ~headers ~status ~body () diff --git a/oauth_cohttp_http_client.ml b/oauth_cohttp_http_client.ml new file mode 100644 index 0000000..768b899 --- /dev/null +++ b/oauth_cohttp_http_client.ml @@ -0,0 +1,36 @@ +module C = Cohttp +module CU = Cohttp_lwt_unix +module CB = Cohttp_lwt_body + +let (>>=) = Lwt.bind + +type status = C.Code.status + +module Opt = struct + type 'a t = 'a option + let (>>=) x f = match x with Some v -> f v | None -> None + let (>|=) x f = match x with Some v -> Some (f v) | None -> None + let run x = match x with Some v -> v | None -> raise (Invalid_argument "run") + let default d x = match x with Some v -> v | None -> d +end + +module Monad = Lwt + +let request ?http_method ~url ?headers ?params ?body () = + let uri = Uri.of_string url in + let uri = match params with + | Some p -> Uri.with_query' uri p + | None -> uri + in + CU.Client.call + ?headers:Opt.(headers >|= fun hs -> C.Header.of_list hs) + ?body:Opt.(body >>= fun b -> CB.body_of_string b) + Opt.(default `GET http_method) + uri + >>= function + | None -> Lwt.fail (Failure "Connection did not succeed") + | Some (response, body) -> + let status = CU.Response.status response in + let headers = C.Header.to_list (CU.Response.headers response) in + CB.string_of_body body >>= fun body_string -> + Lwt.return (status, headers, body_string) diff --git a/oauth_common.ml b/oauth_common.ml index e0ca6d5..10660c6 100644 --- a/oauth_common.ml +++ b/oauth_common.ml @@ -7,13 +7,13 @@ let opt_param name param = let rng = Cryptokit.Random.device_rng "/dev/random" -let rfc3986_encode s = Netencoding.Url.encode s -let rfc3986_decode s = Netencoding.Url.decode s +let rfc3986_encode = Uri.pct_encode ~component:`Authority +let rfc3986_decode = Uri.pct_decode let string_of_http_method = function - | `Get -> "GET" - | `Post -> "POST" - | `Head -> "HEAD" + | `GET -> "GET" + | `POST -> "POST" + | `HEAD -> "HEAD" let string_of_signature_method = function | `Plaintext -> "PLAINTEXT" @@ -27,9 +27,10 @@ let signature_method_of_string rsa_key = function | _ -> raise Not_found let normalize_url url = - let url = Neturl.parse_url ~enable_fragment:true url in - let url = Neturl.remove_from_url ~query:true ~fragment:true url in - Neturl.string_of_url url + let open Uri in + let url = of_string url in + let url = with_query url [] |> fun uri -> with_fragment uri None in + to_string url let string_of_timestamp t = let s = string_of_float t in diff --git a/oauth_ocurl_http_client.ml b/oauth_ocurl_http_client.ml index 53e5e59..8523527 100644 --- a/oauth_ocurl_http_client.ml +++ b/oauth_ocurl_http_client.ml @@ -1,5 +1,49 @@ (* Ocamlnet Http_client doesn't support SSL *) +let status_of_code = function + | 100 -> `Continue + | 101 -> `Switching_protocols + | 200 -> `OK + | 201 -> `Created + | 202 -> `Accepted + | 203 -> `Non_authoritative_information + | 204 -> `No_content + | 205 -> `Reset_content + | 206 -> `Partial_content + | 300 -> `Multiple_choices + | 301 -> `Moved_permanently + | 302 -> `Found + | 303 -> `See_other + | 304 -> `Not_modified + | 305 -> `Use_proxy + | 307 -> `Temporary_redirect + | 400 -> `Bad_request + | 401 -> `Unauthorized + | 402 -> `Payment_required + | 403 -> `Forbidden + | 404 -> `Not_found + | 405 -> `Method_not_allowed + | 406 -> `Not_acceptable + | 407 -> `Proxy_authentication_required + | 408 -> `Request_time_out + | 409 -> `Conflict + | 410 -> `Gone + | 411 -> `Length_required + | 412 -> `Precondition_failed + | 413 -> `Request_entity_too_large + | 414 -> `Request_URI_too_large + | 415 -> `Unsupported_media_type + | 416 -> `Requested_range_not_satisfiable + | 417 -> `Expectation_failed + | 422 -> `Unprocessable_entity + | 500 -> `Internal_server_error + | 501 -> `Not_implemented + | 502 -> `Bad_gateway + | 503 -> `Service_unavailable + | 504 -> `Gateway_time_out + | 505 -> `HTTP_version_not_supported + | code -> `Code code + let request ?(http_method = `Post) ~url @@ -11,7 +55,7 @@ let request let b = Buffer.create 1024 in let oc = Curl.init() in - let query = Netencoding.Url.mk_url_encoded_parameters params in + let query = Uri.encoded_of_query (List.map (fun (k,v) -> (k, [v])) params) in let headers = match http_method, body with | `Post, None -> @@ -47,33 +91,45 @@ let request (* adapted from Ocamlnet http_client.ml *) try - let line_end_re = Netstring_pcre.regexp "[^\\x00\r\n]+\r?\n" in - let line_end2_re = Netstring_pcre.regexp "([^\\x00\r\n]+\r?\n)*\r?\n" in - let status_re = Netstring_pcre.regexp "^([^ \t]+)[ \t]+([0-9][0-9][0-9])([ \t]+([^\r\n]*))?\r?\n$" in + let open Re_pcre in + let line_end_re = regexp "[^\\x00\r\n]+\r?\n" in + let line_end2_re = regexp "([^\\x00\r\n]+\r?\n)*\r?\n" in + let status_re = regexp "^([^ \t]+)[ \t]+([0-9][0-9][0-9])([ \t]+([^\r\n]*))?\r?\n$" in + + let string_match rex s pos = + try + let result = Re_pcre.exec ~rex ~pos s in + Some result + with Not_found -> None + in + + let matched_group result n _ = Re_pcre.get_substring result n in + let matched_string result _ = Re_pcre.get_substring result 0 in + let match_end result = snd (Re_pcre.get_substring_ofs result 0) in let c = Buffer.contents h in let code, in_pos = (* Parses the status line. If 1XX: do XXX *) - match Netstring_pcre.string_match line_end_re c 0 with + match string_match line_end_re c 0 with | None -> raise (Failure "couldn't parse status") | Some m -> - let s = Netstring_pcre.matched_string m c in - match Netstring_pcre.string_match status_re s 0 with + let s = matched_string m c in + match string_match status_re s 0 with | None -> raise (Failure "Bad status line") | Some m -> - let code_str = Netstring_pcre.matched_group m 2 s in + let code_str = matched_group m 2 s in let code = int_of_string code_str in if code < 100 || code > 599 then raise (Failure "Bad status code") - else Nethttp.http_status_of_int code, Netstring_pcre.match_end m in + else status_of_code code, match_end m in let header = (* Parses the HTTP header following the status line *) - match Netstring_pcre.string_match line_end2_re c in_pos with + match string_match line_end2_re c in_pos with | None -> raise (Failure "couldn't parse header") | Some m -> let start = in_pos in - let in_pos = Netstring_pcre.match_end m in + let in_pos = match_end m in let header_l, _ = Mimestring.scan_header ~downcase:false ~unfold:true ~strip:true c diff --git a/oauth_server.ml b/oauth_server.ml index 2c52a23..0bbb13d 100644 --- a/oauth_server.ml +++ b/oauth_server.ml @@ -1,16 +1,67 @@ module type Http = sig + module Monad : sig + type 'a t + val return : 'a -> 'a t + val fail : exn -> 'a t + val (>>=) : 'a t -> ('a -> 'b t) -> 'b t + val (>|=) : 'a t -> ('a -> 'b) -> 'b t + end + + type status = + [ `Accepted + | `Bad_gateway + | `Bad_request + | `Conflict + | `Continue + | `Created + | `Expectation_failed + | `Forbidden + | `Found + | `Gateway_time_out + | `Gone + | `HTTP_version_not_supported + | `Internal_server_error + | `Length_required + | `Method_not_allowed + | `Moved_permanently + | `Multiple_choices + | `No_content + | `Non_authoritative_information + | `Not_acceptable + | `Not_found + | `Not_implemented + | `Not_modified + | `OK + | `Partial_content + | `Payment_required + | `Precondition_failed + | `Proxy_authentication_required + | `Request_URI_too_large + | `Request_entity_too_large + | `Request_time_out + | `Requested_range_not_satisfiable + | `Reset_content + | `See_other + | `Service_unavailable + | `Switching_protocols + | `Temporary_redirect + | `Unauthorized + | `Unprocessable_entity + | `Unsupported_media_type + | `Use_proxy ] + type request - val http_method : request -> [ `Get | `Post | `Head ] + val http_method : request -> [ `GET | `POST | `HEAD ] val url : request -> string val header : request -> string -> string (* throws Not_found *) val argument : request -> ?default:string -> string -> string (* throws Not_found *) val arguments : request -> (string * string) list type response - val respond : request -> Nethttp.http_status -> (string * string) list -> string -> response + val respond : request -> status -> (string * string) list -> string -> response Monad.t - exception Error of Nethttp.http_status * string + exception Error of status * string end module type Db = @@ -52,11 +103,11 @@ struct let arg = try let h = Http.header req "Authorization" in - let parts = Pcre.split ~pat:"\\s*,\\s*" h in + let parts = Re_pcre.(split ~rex:(regexp "\\s*,\\s*") h) in let args = List.map (fun p -> - match Pcre.extract ~pat:"(\\S*)\\s*=\\s*\"([^\"]*)\"" p with + match Re_pcre.(extract ~rex:(regexp "(\\S*)\\s*=\\s*\"([^\"]*)\"") p) with | [| _; k; v |] -> k, Oauth_common.rfc3986_decode v | _ -> raise Not_found) (* bad header, fall back to CGI args (?) *) parts in @@ -134,10 +185,10 @@ struct () then let request_token = Db.make_request_token consumer req in - Http.respond req `Ok [] - (Netencoding.Url.mk_url_encoded_parameters [ - "oauth_token", Db.request_token_token request_token; - "oauth_token_secret", Db.request_token_secret request_token; + Http.respond req `OK [] + (Uri.encoded_of_query [ + "oauth_token", [Db.request_token_token request_token]; + "oauth_token_secret", [Db.request_token_secret request_token]; ]) else unauthorized "invalid signature" in @@ -177,10 +228,10 @@ struct let access_token = try Db.exchange_request_token request_token with Failure msg -> unauthorized msg in - Http.respond req `Ok [] - (Netencoding.Url.mk_url_encoded_parameters [ - "oauth_token", Db.access_token_token access_token; - "oauth_token_secret", Db.access_token_secret access_token; + Http.respond req `OK [] + (Uri.encoded_of_query [ + "oauth_token", [Db.access_token_token access_token]; + "oauth_token_secret", [Db.access_token_secret access_token]; ]) else unauthorized "invalid signature" in @@ -201,9 +252,9 @@ struct then bad_request "request token already authorized"; match Http.http_method req with - | `Get -> + | `GET -> kget oauth_token request_token req - | `Post -> + | `POST -> Db.authorize_request_token request_token req; kpost oauth_token request_token req | _ -> raise (Http.Error (`Method_not_allowed, "")) diff --git a/oauth_server.mli b/oauth_server.mli index 576c136..af4bdb6 100644 --- a/oauth_server.mli +++ b/oauth_server.mli @@ -1,16 +1,67 @@ module type Http = sig + module Monad : sig + type 'a t + val return : 'a -> 'a t + val fail : exn -> 'a t + val (>>=) : 'a t -> ('a -> 'b t) -> 'b t + val (>|=) : 'a t -> ('a -> 'b) -> 'b t + end + + type status = + [ `Accepted + | `Bad_gateway + | `Bad_request + | `Conflict + | `Continue + | `Created + | `Expectation_failed + | `Forbidden + | `Found + | `Gateway_time_out + | `Gone + | `HTTP_version_not_supported + | `Internal_server_error + | `Length_required + | `Method_not_allowed + | `Moved_permanently + | `Multiple_choices + | `No_content + | `Non_authoritative_information + | `Not_acceptable + | `Not_found + | `Not_implemented + | `Not_modified + | `OK + | `Partial_content + | `Payment_required + | `Precondition_failed + | `Proxy_authentication_required + | `Request_URI_too_large + | `Request_entity_too_large + | `Request_time_out + | `Requested_range_not_satisfiable + | `Reset_content + | `See_other + | `Service_unavailable + | `Switching_protocols + | `Temporary_redirect + | `Unauthorized + | `Unprocessable_entity + | `Unsupported_media_type + | `Use_proxy ] + type request - val http_method : request -> [ `Get | `Post | `Head ] + val http_method : request -> [ `GET | `POST | `HEAD ] val url : request -> string val header : request -> string -> string (* throws Not_found *) val argument : request -> ?default:string -> string -> string (* throws Not_found *) val arguments : request -> (string * string) list type response - val respond : request -> Nethttp.http_status -> (string * string) list -> string -> response + val respond : request -> status -> (string * string) list -> string -> response Monad.t - exception Error of Nethttp.http_status * string + exception Error of status * string end module type Db = @@ -40,24 +91,22 @@ sig val access_token_secret : access_token -> string end -module Make : - functor (Http : Http) -> - functor (Db : Db with module Http = Http) -> +module Make (Http : Http) (Db : Db with module Http = Http) : sig - val fetch_request_token : Http.request -> Http.response + val fetch_request_token : Http.request -> Http.response Http.Monad.t - val fetch_access_token : Http.request -> Http.response + val fetch_access_token : Http.request -> Http.response Http.Monad.t val authorize_request_token : Http.request -> - (string -> Db.request_token -> Http.request -> Http.response) -> - (string -> Db.request_token -> Http.request -> Http.response) -> - Http.response + (string -> Db.request_token -> Http.request -> Http.response Http.Monad.t) -> + (string -> Db.request_token -> Http.request -> Http.response Http.Monad.t) -> + Http.response Http.Monad.t val access_resource : Http.request -> - (string -> Db.access_token -> Http.request -> Http.response) -> - Http.response + (string -> Db.access_token -> Http.request -> Http.response Http.Monad.t) -> + Http.response Http.Monad.t end diff --git a/ooauth.mllib b/ooauth.mllib index f4282a4..ef0ed3b 100644 --- a/ooauth.mllib +++ b/ooauth.mllib @@ -3,6 +3,8 @@ Oauth_common Oauth_client Oauth_server Oauth_util -Oauth_ocurl_http_client -Oauth_netclient_http_client -Oauth_netcgi_http +Oauth_cohttp_http_client +Oauth_cohttp_http +#Oauth_ocurl_http_client +#Oauth_netclient_http_client +#Oauth_netcgi_http From d0d03e387289fca302d778586770e8bd45b4fd1c Mon Sep 17 00:00:00 2001 From: Vincent Bernardoff Date: Thu, 3 Oct 2013 18:05:10 +0200 Subject: [PATCH 05/14] OASISified. --- META | 6 - Makefile | 66 +- _oasis | 35 + _tags | 34 +- cohttp/oauth_cohttp.mllib | 5 + .../oauth_cohttp_http.ml | 0 .../oauth_cohttp_http_client.ml | 0 configure | 27 + .../oauth_ocurl_http_client.ml | 0 examples/Makefile | 3 - examples/localhost/_tags | 4 - examples/localhost/client.ml | 4 +- examples/term.ie/_tags | 3 - lib/META | 22 + lib/oauth.mllib | 7 + oauth_base32.ml => lib/oauth_base32.ml | 0 oauth_base32.mli => lib/oauth_base32.mli | 0 oauth_client.ml => lib/oauth_client.ml | 0 oauth_client.mli => lib/oauth_client.mli | 0 oauth_common.ml => lib/oauth_common.ml | 0 oauth_server.ml => lib/oauth_server.ml | 0 oauth_server.mli => lib/oauth_server.mli | 0 oauth_util.ml => lib/oauth_util.ml | 0 myocamlbuild.ml | 522 ++ .../oauth_netcgi_http.ml | 0 .../oauth_netclient_http_client.ml | 0 ooauth.mllib | 10 - setup.ml | 6025 +++++++++++++++++ 28 files changed, 6711 insertions(+), 62 deletions(-) delete mode 100644 META create mode 100644 _oasis create mode 100644 cohttp/oauth_cohttp.mllib rename oauth_cohttp_http.ml => cohttp/oauth_cohttp_http.ml (100%) rename oauth_cohttp_http_client.ml => cohttp/oauth_cohttp_http_client.ml (100%) create mode 100755 configure rename oauth_ocurl_http_client.ml => curl/oauth_ocurl_http_client.ml (100%) delete mode 100644 examples/Makefile delete mode 100644 examples/localhost/_tags delete mode 100644 examples/term.ie/_tags create mode 100644 lib/META create mode 100644 lib/oauth.mllib rename oauth_base32.ml => lib/oauth_base32.ml (100%) rename oauth_base32.mli => lib/oauth_base32.mli (100%) rename oauth_client.ml => lib/oauth_client.ml (100%) rename oauth_client.mli => lib/oauth_client.mli (100%) rename oauth_common.ml => lib/oauth_common.ml (100%) rename oauth_server.ml => lib/oauth_server.ml (100%) rename oauth_server.mli => lib/oauth_server.mli (100%) rename oauth_util.ml => lib/oauth_util.ml (100%) create mode 100644 myocamlbuild.ml rename oauth_netcgi_http.ml => ocamlnet/oauth_netcgi_http.ml (100%) rename oauth_netclient_http_client.ml => ocamlnet/oauth_netclient_http_client.ml (100%) delete mode 100644 ooauth.mllib create mode 100644 setup.ml diff --git a/META b/META deleted file mode 100644 index 5f0b795..0000000 --- a/META +++ /dev/null @@ -1,6 +0,0 @@ -name="OOAuth" -version="0.1" -description="OAuth implementation" -requires="pcre, cryptokit, netstring, netstring-pcre, curl, netclient" -archive(byte) = "ooauth.cma" -archive(native) = "ooauth.cmxa" diff --git a/Makefile b/Makefile index 37db4c6..68f2e0e 100644 --- a/Makefile +++ b/Makefile @@ -1,28 +1,38 @@ -PREFIX=/usr/local -FILES=\ -ooauth.cma ooauth.cmxa ooauth.a \ -oauth_client.mli oauth_client.cmi \ -oauth_server.mli oauth_server.cmi \ -oauth_base32.mli oauth_base32.cmi \ -oauth_util.cmi -#oauth_ocurl_http_client.cmi \ -#oauth_netclient_http_client.cmi \ -#oauth_netcgi_http.cmi - -BFILES=$(addprefix _build/,$(FILES)) - -all: - ocamlbuild -use-ocamlfind ooauth.cma ooauth.cmxa - -install: all - ocamlfind install ooauth META $(BFILES) - -uninstall: - ocamlfind remove ooauth - -clean: - ocamlbuild -clean - $(MAKE) -C examples clean - -dist: clean - cd ..; tar cvfz ooauth.tar.gz --exclude .svn ooauth +# OASIS_START +# DO NOT EDIT (digest: bc1e05bfc8b39b664f29dae8dbd3ebbb) + +SETUP = ocaml setup.ml + +build: setup.data + $(SETUP) -build $(BUILDFLAGS) + +doc: setup.data build + $(SETUP) -doc $(DOCFLAGS) + +test: setup.data build + $(SETUP) -test $(TESTFLAGS) + +all: + $(SETUP) -all $(ALLFLAGS) + +install: setup.data + $(SETUP) -install $(INSTALLFLAGS) + +uninstall: setup.data + $(SETUP) -uninstall $(UNINSTALLFLAGS) + +reinstall: setup.data + $(SETUP) -reinstall $(REINSTALLFLAGS) + +clean: + $(SETUP) -clean $(CLEANFLAGS) + +distclean: + $(SETUP) -distclean $(DISTCLEANFLAGS) + +setup.data: + $(SETUP) -configure $(CONFIGUREFLAGS) + +.PHONY: build doc test all install uninstall reinstall clean distclean configure + +# OASIS_STOP diff --git a/_oasis b/_oasis new file mode 100644 index 0000000..f2b901e --- /dev/null +++ b/_oasis @@ -0,0 +1,35 @@ +OASISFormat: 0.3 +Name: ooauth +Version: 0.1 +Synopsis: OAuth for OCaml +Authors: Jake Donham, Vincent Bernardoff +License: ISC +Plugins: META (0.3), DevFiles (0.3) +BuildTools: ocamlbuild + +Flag cohttp + Description: build the Cohttp library + Default: true + +Flag ocurl + Description: build the OCurl library + Default: false + +Flag ocamlnet + Description: build the Ocamlnet library + Default: false + +Library oauth + Path: lib + Findlibname: oauth + Modules: Oauth_util, Oauth_base32, Oauth_common, Oauth_client + BuildDepends: cryptokit, uri, re + +Library oauth_cohttp + Build$: flag(cohttp) + Install$: flag(cohttp) + Path: cohttp + Findlibname: cohttp + Findlibparent: oauth + BuildDepends: oauth, cohttp.lwt + Modules: Oauth_cohttp_http, Oauth_cohttp_http_client diff --git a/_tags b/_tags index 30486a0..cfd4924 100644 --- a/_tags +++ b/_tags @@ -1,6 +1,28 @@ -<*.ml*> : debug, package(cryptokit), package(uri) - : package(cohttp.lwt) - : package(cohttp.lwt) - : package(curl) - : package(netclient) - : package(netcgi2) +# OASIS_START +# DO NOT EDIT (digest: 35491c1f6e5569948dbda548078fec08) +# Ignore VCS directories, you can use the same kind of rule outside +# OASIS_START/STOP if you want to exclude directories that contains +# useless stuff for the build process +<**/.svn>: -traverse +<**/.svn>: not_hygienic +".bzr": -traverse +".bzr": not_hygienic +".hg": -traverse +".hg": not_hygienic +".git": -traverse +".git": not_hygienic +"_darcs": -traverse +"_darcs": not_hygienic +# Library oauth +"lib/oauth.cmxs": use_oauth +: pkg_cryptokit +: pkg_uri +: pkg_re +# Library oauth_cohttp +"cohttp/oauth_cohttp.cmxs": use_oauth_cohttp +: use_oauth +: pkg_cohttp.lwt +: pkg_cryptokit +: pkg_uri +: pkg_re +# OASIS_STOP diff --git a/cohttp/oauth_cohttp.mllib b/cohttp/oauth_cohttp.mllib new file mode 100644 index 0000000..6678519 --- /dev/null +++ b/cohttp/oauth_cohttp.mllib @@ -0,0 +1,5 @@ +# OASIS_START +# DO NOT EDIT (digest: cfc2e2d8157ac69c166bc821d9df1bcb) +Oauth_cohttp_http +Oauth_cohttp_http_client +# OASIS_STOP diff --git a/oauth_cohttp_http.ml b/cohttp/oauth_cohttp_http.ml similarity index 100% rename from oauth_cohttp_http.ml rename to cohttp/oauth_cohttp_http.ml diff --git a/oauth_cohttp_http_client.ml b/cohttp/oauth_cohttp_http_client.ml similarity index 100% rename from oauth_cohttp_http_client.ml rename to cohttp/oauth_cohttp_http_client.ml diff --git a/configure b/configure new file mode 100755 index 0000000..97ed012 --- /dev/null +++ b/configure @@ -0,0 +1,27 @@ +#!/bin/sh + +# OASIS_START +# DO NOT EDIT (digest: 425187ed8bfdbdd207fd76392dd243a7) +set -e + +FST=true +for i in "$@"; do + if $FST; then + set -- + FST=false + fi + + case $i in + --*=*) + ARG=${i%%=*} + VAL=${i##*=} + set -- "$@" "$ARG" "$VAL" + ;; + *) + set -- "$@" "$i" + ;; + esac +done + +ocaml setup.ml -configure "$@" +# OASIS_STOP diff --git a/oauth_ocurl_http_client.ml b/curl/oauth_ocurl_http_client.ml similarity index 100% rename from oauth_ocurl_http_client.ml rename to curl/oauth_ocurl_http_client.ml diff --git a/examples/Makefile b/examples/Makefile deleted file mode 100644 index 70f568d..0000000 --- a/examples/Makefile +++ /dev/null @@ -1,3 +0,0 @@ -clean: - $(MAKE) -C localhost clean - $(MAKE) -C term.ie clean diff --git a/examples/localhost/_tags b/examples/localhost/_tags deleted file mode 100644 index 07c4288..0000000 --- a/examples/localhost/_tags +++ /dev/null @@ -1,4 +0,0 @@ -<*.ml*> : debug, package(ooauth), package(crypto_keys) -<*.byte> : debug, package(ooauth), package(crypto_keys) - : package(netplex), package(nethttpd) -<*.byte> : package(netplex), package(nethttpd), package(crypto_keys) diff --git a/examples/localhost/client.ml b/examples/localhost/client.ml index 653e79c..8760d62 100644 --- a/examples/localhost/client.ml +++ b/examples/localhost/client.ml @@ -6,11 +6,11 @@ problem with the 100 Continue status line--Ocurl returns the 100 status instead of the real status. not sure who is at fault. *) -module OC = Oauth_client.Make(Oauth_netclient_http_client) +module OC = Oauth_client.Make(Oauth_cohttp_http_client) let rsa_key = Rsa.read_rsa_privkey "private_key.pem" let oauth_signature_method = `Rsa_sha1 rsa_key -let http_method = `Post +let http_method = `POST let url s = "http://localhost:8767" ^ s diff --git a/examples/term.ie/_tags b/examples/term.ie/_tags deleted file mode 100644 index cb50ea5..0000000 --- a/examples/term.ie/_tags +++ /dev/null @@ -1,3 +0,0 @@ -<*.ml*>: debug, package(ooauth), package(crypto_keys) -<*.byte>: debug, package(ooauth), package(crypto_keys) -true: annot diff --git a/lib/META b/lib/META new file mode 100644 index 0000000..d4cba5f --- /dev/null +++ b/lib/META @@ -0,0 +1,22 @@ +# OASIS_START +# DO NOT EDIT (digest: 3478246be9a44fd86570d1b1d4b9ad48) +version = "0.1" +description = "OAuth for OCaml" +requires = "cryptokit uri re" +archive(byte) = "oauth.cma" +archive(byte, plugin) = "oauth.cma" +archive(native) = "oauth.cmxa" +archive(native, plugin) = "oauth.cmxs" +exists_if = "oauth.cma" +package "cohttp" ( + version = "0.1" + description = "OAuth for OCaml" + requires = "oauth cohttp.lwt" + archive(byte) = "oauth_cohttp.cma" + archive(byte, plugin) = "oauth_cohttp.cma" + archive(native) = "oauth_cohttp.cmxa" + archive(native, plugin) = "oauth_cohttp.cmxs" + exists_if = "oauth_cohttp.cma" +) +# OASIS_STOP + diff --git a/lib/oauth.mllib b/lib/oauth.mllib new file mode 100644 index 0000000..b195350 --- /dev/null +++ b/lib/oauth.mllib @@ -0,0 +1,7 @@ +# OASIS_START +# DO NOT EDIT (digest: 585e4ab866bc1003b3f80308f654d541) +Oauth_util +Oauth_base32 +Oauth_common +Oauth_client +# OASIS_STOP diff --git a/oauth_base32.ml b/lib/oauth_base32.ml similarity index 100% rename from oauth_base32.ml rename to lib/oauth_base32.ml diff --git a/oauth_base32.mli b/lib/oauth_base32.mli similarity index 100% rename from oauth_base32.mli rename to lib/oauth_base32.mli diff --git a/oauth_client.ml b/lib/oauth_client.ml similarity index 100% rename from oauth_client.ml rename to lib/oauth_client.ml diff --git a/oauth_client.mli b/lib/oauth_client.mli similarity index 100% rename from oauth_client.mli rename to lib/oauth_client.mli diff --git a/oauth_common.ml b/lib/oauth_common.ml similarity index 100% rename from oauth_common.ml rename to lib/oauth_common.ml diff --git a/oauth_server.ml b/lib/oauth_server.ml similarity index 100% rename from oauth_server.ml rename to lib/oauth_server.ml diff --git a/oauth_server.mli b/lib/oauth_server.mli similarity index 100% rename from oauth_server.mli rename to lib/oauth_server.mli diff --git a/oauth_util.ml b/lib/oauth_util.ml similarity index 100% rename from oauth_util.ml rename to lib/oauth_util.ml diff --git a/myocamlbuild.ml b/myocamlbuild.ml new file mode 100644 index 0000000..d1f7e26 --- /dev/null +++ b/myocamlbuild.ml @@ -0,0 +1,522 @@ +(* OASIS_START *) +(* DO NOT EDIT (digest: 6f55567a591f9c6aae89e1411a71e9c6) *) +module OASISGettext = struct +(* # 21 "src/oasis/OASISGettext.ml" *) + + let ns_ str = + str + + let s_ str = + str + + let f_ (str : ('a, 'b, 'c, 'd) format4) = + str + + let fn_ fmt1 fmt2 n = + if n = 1 then + fmt1^^"" + else + fmt2^^"" + + let init = + [] + +end + +module OASISExpr = struct +(* # 21 "src/oasis/OASISExpr.ml" *) + + + + open OASISGettext + + type test = string + + type flag = string + + type t = + | EBool of bool + | ENot of t + | EAnd of t * t + | EOr of t * t + | EFlag of flag + | ETest of test * string + + + type 'a choices = (t * 'a) list + + let eval var_get t = + let rec eval' = + function + | EBool b -> + b + + | ENot e -> + not (eval' e) + + | EAnd (e1, e2) -> + (eval' e1) && (eval' e2) + + | EOr (e1, e2) -> + (eval' e1) || (eval' e2) + + | EFlag nm -> + let v = + var_get nm + in + assert(v = "true" || v = "false"); + (v = "true") + + | ETest (nm, vl) -> + let v = + var_get nm + in + (v = vl) + in + eval' t + + let choose ?printer ?name var_get lst = + let rec choose_aux = + function + | (cond, vl) :: tl -> + if eval var_get cond then + vl + else + choose_aux tl + | [] -> + let str_lst = + if lst = [] then + s_ "" + else + String.concat + (s_ ", ") + (List.map + (fun (cond, vl) -> + match printer with + | Some p -> p vl + | None -> s_ "") + lst) + in + match name with + | Some nm -> + failwith + (Printf.sprintf + (f_ "No result for the choice list '%s': %s") + nm str_lst) + | None -> + failwith + (Printf.sprintf + (f_ "No result for a choice list: %s") + str_lst) + in + choose_aux (List.rev lst) + +end + + +# 117 "myocamlbuild.ml" +module BaseEnvLight = struct +(* # 21 "src/base/BaseEnvLight.ml" *) + + module MapString = Map.Make(String) + + type t = string MapString.t + + let default_filename = + Filename.concat + (Sys.getcwd ()) + "setup.data" + + let load ?(allow_empty=false) ?(filename=default_filename) () = + if Sys.file_exists filename then + begin + let chn = + open_in_bin filename + in + let st = + Stream.of_channel chn + in + let line = + ref 1 + in + let st_line = + Stream.from + (fun _ -> + try + match Stream.next st with + | '\n' -> incr line; Some '\n' + | c -> Some c + with Stream.Failure -> None) + in + let lexer = + Genlex.make_lexer ["="] st_line + in + let rec read_file mp = + match Stream.npeek 3 lexer with + | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> + Stream.junk lexer; + Stream.junk lexer; + Stream.junk lexer; + read_file (MapString.add nm value mp) + | [] -> + mp + | _ -> + failwith + (Printf.sprintf + "Malformed data file '%s' line %d" + filename !line) + in + let mp = + read_file MapString.empty + in + close_in chn; + mp + end + else if allow_empty then + begin + MapString.empty + end + else + begin + failwith + (Printf.sprintf + "Unable to load environment, the file '%s' doesn't exist." + filename) + end + + let var_get name env = + let rec var_expand str = + let buff = + Buffer.create ((String.length str) * 2) + in + Buffer.add_substitute + buff + (fun var -> + try + var_expand (MapString.find var env) + with Not_found -> + failwith + (Printf.sprintf + "No variable %s defined when trying to expand %S." + var + str)) + str; + Buffer.contents buff + in + var_expand (MapString.find name env) + + let var_choose lst env = + OASISExpr.choose + (fun nm -> var_get nm env) + lst +end + + +# 215 "myocamlbuild.ml" +module MyOCamlbuildFindlib = struct +(* # 21 "src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) + + (** OCamlbuild extension, copied from + * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild + * by N. Pouillard and others + * + * Updated on 2009/02/28 + * + * Modified by Sylvain Le Gall + *) + open Ocamlbuild_plugin + + (* these functions are not really officially exported *) + let run_and_read = + Ocamlbuild_pack.My_unix.run_and_read + + let blank_sep_strings = + Ocamlbuild_pack.Lexers.blank_sep_strings + + let split s ch = + let buf = Buffer.create 13 in + let x = ref [] in + let flush () = + x := (Buffer.contents buf) :: !x; + Buffer.clear buf + in + String.iter + (fun c -> + if c = ch then + flush () + else + Buffer.add_char buf c) + s; + flush (); + List.rev !x + + let split_nl s = split s '\n' + + let before_space s = + try + String.before s (String.index s ' ') + with Not_found -> s + + (* this lists all supported packages *) + let find_packages () = + List.map before_space (split_nl & run_and_read "ocamlfind list") + + (* this is supposed to list available syntaxes, but I don't know how to do it. *) + let find_syntaxes () = ["camlp4o"; "camlp4r"] + + (* ocamlfind command *) + let ocamlfind x = S[A"ocamlfind"; x] + + let dispatch = + function + | Before_options -> + (* by using Before_options one let command line options have an higher priority *) + (* on the contrary using After_options will guarantee to have the higher priority *) + (* override default commands by ocamlfind ones *) + Options.ocamlc := ocamlfind & A"ocamlc"; + Options.ocamlopt := ocamlfind & A"ocamlopt"; + Options.ocamldep := ocamlfind & A"ocamldep"; + Options.ocamldoc := ocamlfind & A"ocamldoc"; + Options.ocamlmktop := ocamlfind & A"ocamlmktop" + + | After_rules -> + + (* When one link an OCaml library/binary/package, one should use -linkpkg *) + flag ["ocaml"; "link"; "program"] & A"-linkpkg"; + flag ["ocaml"; "link"; "output_obj"] & A"-linkpkg"; + + (* For each ocamlfind package one inject the -package option when + * compiling, computing dependencies, generating documentation and + * linking. *) + List.iter + begin fun pkg -> + let base_args = [A"-package"; A pkg] in + let syn_args = [A"-syntax"; A "camlp4o"] in + let args = + (* heuristic to identify syntax extensions: + whether they end in ".syntax"; some might not *) + if Filename.check_suffix pkg "syntax" + then syn_args @ base_args + else base_args + in + flag ["ocaml"; "compile"; "pkg_"^pkg] & S args; + flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S args; + flag ["ocaml"; "doc"; "pkg_"^pkg] & S args; + flag ["ocaml"; "link"; "pkg_"^pkg] & S base_args; + flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S args; + end + (find_packages ()); + + (* Like -package but for extensions syntax. Morover -syntax is useless + * when linking. *) + List.iter begin fun syntax -> + flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; + flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; + flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; + flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; + end (find_syntaxes ()); + + (* The default "thread" tag is not compatible with ocamlfind. + * Indeed, the default rules add the "threads.cma" or "threads.cmxa" + * options when using this tag. When using the "-linkpkg" option with + * ocamlfind, this module will then be added twice on the command line. + * + * To solve this, one approach is to add the "-thread" option when using + * the "threads" package using the previous plugin. + *) + flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]); + flag ["ocaml"; "pkg_threads"; "doc"] (S[A "-I"; A "+threads"]); + flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]); + flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"]) + + | _ -> + () + +end + +module MyOCamlbuildBase = struct +(* # 21 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) + + (** Base functions for writing myocamlbuild.ml + @author Sylvain Le Gall + *) + + + + open Ocamlbuild_plugin + module OC = Ocamlbuild_pack.Ocaml_compiler + + type dir = string + type file = string + type name = string + type tag = string + +(* # 56 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) + + type t = + { + lib_ocaml: (name * dir list) list; + lib_c: (name * dir * file list) list; + flags: (tag list * (spec OASISExpr.choices)) list; + (* Replace the 'dir: include' from _tags by a precise interdepends in + * directory. + *) + includes: (dir * dir list) list; + } + + let env_filename = + Pathname.basename + BaseEnvLight.default_filename + + let dispatch_combine lst = + fun e -> + List.iter + (fun dispatch -> dispatch e) + lst + + let tag_libstubs nm = + "use_lib"^nm^"_stubs" + + let nm_libstubs nm = + nm^"_stubs" + + let dispatch t e = + let env = + BaseEnvLight.load + ~filename:env_filename + ~allow_empty:true + () + in + match e with + | Before_options -> + let no_trailing_dot s = + if String.length s >= 1 && s.[0] = '.' then + String.sub s 1 ((String.length s) - 1) + else + s + in + List.iter + (fun (opt, var) -> + try + opt := no_trailing_dot (BaseEnvLight.var_get var env) + with Not_found -> + Printf.eprintf "W: Cannot get variable %s" var) + [ + Options.ext_obj, "ext_obj"; + Options.ext_lib, "ext_lib"; + Options.ext_dll, "ext_dll"; + ] + + | After_rules -> + (* Declare OCaml libraries *) + List.iter + (function + | nm, [] -> + ocaml_lib nm + | nm, dir :: tl -> + ocaml_lib ~dir:dir (dir^"/"^nm); + List.iter + (fun dir -> + List.iter + (fun str -> + flag ["ocaml"; "use_"^nm; str] (S[A"-I"; P dir])) + ["compile"; "infer_interface"; "doc"]) + tl) + t.lib_ocaml; + + (* Declare directories dependencies, replace "include" in _tags. *) + List.iter + (fun (dir, include_dirs) -> + Pathname.define_context dir include_dirs) + t.includes; + + (* Declare C libraries *) + List.iter + (fun (lib, dir, headers) -> + (* Handle C part of library *) + flag ["link"; "library"; "ocaml"; "byte"; tag_libstubs lib] + (S[A"-dllib"; A("-l"^(nm_libstubs lib)); A"-cclib"; + A("-l"^(nm_libstubs lib))]); + + flag ["link"; "library"; "ocaml"; "native"; tag_libstubs lib] + (S[A"-cclib"; A("-l"^(nm_libstubs lib))]); + + flag ["link"; "program"; "ocaml"; "byte"; tag_libstubs lib] + (S[A"-dllib"; A("dll"^(nm_libstubs lib))]); + + (* When ocaml link something that use the C library, then one + need that file to be up to date. + *) + dep ["link"; "ocaml"; "program"; tag_libstubs lib] + [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; + + dep ["compile"; "ocaml"; "program"; tag_libstubs lib] + [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; + + (* TODO: be more specific about what depends on headers *) + (* Depends on .h files *) + dep ["compile"; "c"] + headers; + + (* Setup search path for lib *) + flag ["link"; "ocaml"; "use_"^lib] + (S[A"-I"; P(dir)]); + ) + t.lib_c; + + (* Add output_obj rules mapped to .nobj.o *) + let native_output_obj x = + OC.link_gen "cmx" "cmxa" !Options.ext_lib [!Options.ext_obj; "cmi"] + OC.ocamlopt_link_prog + (fun tags -> tags++"ocaml"++"link"++"native"++"output_obj") x + in + rule "ocaml: cmx* and o* -> .nobj.o" ~prod:"%.nobj.o" ~deps:["%.cmx"; "%.o"] + (native_output_obj "%.cmx" "%.nobj.o"); + + (* Add output_obj rules mapped to .bobj.o *) + let bytecode_output_obj x = + OC.link_gen "cmo" "cma" !Options.ext_lib [!Options.ext_obj; "cmi"] + OC.ocamlc_link_prog + (fun tags -> tags++"ocaml"++"link"++"byte"++"output_obj") x + in + rule "ocaml: cmo* -> .nobj.o" ~prod:"%.bobj.o" ~deps:["%.cmo"] + (bytecode_output_obj "%.cmo" "%.bobj.o"); + + (* Add flags *) + List.iter + (fun (tags, cond_specs) -> + let spec = + BaseEnvLight.var_choose cond_specs env + in + flag tags & spec) + t.flags + | _ -> + () + + let dispatch_default t = + dispatch_combine + [ + dispatch t; + MyOCamlbuildFindlib.dispatch; + ] + +end + + +# 506 "myocamlbuild.ml" +open Ocamlbuild_plugin;; +let package_default = + { + MyOCamlbuildBase.lib_ocaml = + [("oauth", ["lib"]); ("oauth_cohttp", ["cohttp"])]; + lib_c = []; + flags = []; + includes = [("cohttp", ["lib"])]; + } + ;; + +let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;; + +# 521 "myocamlbuild.ml" +(* OASIS_STOP *) +Ocamlbuild_plugin.dispatch dispatch_default;; diff --git a/oauth_netcgi_http.ml b/ocamlnet/oauth_netcgi_http.ml similarity index 100% rename from oauth_netcgi_http.ml rename to ocamlnet/oauth_netcgi_http.ml diff --git a/oauth_netclient_http_client.ml b/ocamlnet/oauth_netclient_http_client.ml similarity index 100% rename from oauth_netclient_http_client.ml rename to ocamlnet/oauth_netclient_http_client.ml diff --git a/ooauth.mllib b/ooauth.mllib deleted file mode 100644 index ef0ed3b..0000000 --- a/ooauth.mllib +++ /dev/null @@ -1,10 +0,0 @@ -Oauth_base32 -Oauth_common -Oauth_client -Oauth_server -Oauth_util -Oauth_cohttp_http_client -Oauth_cohttp_http -#Oauth_ocurl_http_client -#Oauth_netclient_http_client -#Oauth_netcgi_http diff --git a/setup.ml b/setup.ml new file mode 100644 index 0000000..9608c2d --- /dev/null +++ b/setup.ml @@ -0,0 +1,6025 @@ +(* setup.ml generated for the first time by OASIS v0.3.1 *) + +(* OASIS_START *) +(* DO NOT EDIT (digest: c53df64906da444f8e1ed5a07d0849c8) *) +(* + Regenerated by OASIS v0.3.1 + Visit http://oasis.forge.ocamlcore.org for more information and + documentation about functions used in this file. +*) +module OASISGettext = struct +(* # 21 "src/oasis/OASISGettext.ml" *) + + let ns_ str = + str + + let s_ str = + str + + let f_ (str : ('a, 'b, 'c, 'd) format4) = + str + + let fn_ fmt1 fmt2 n = + if n = 1 then + fmt1^^"" + else + fmt2^^"" + + let init = + [] + +end + +module OASISContext = struct +(* # 21 "src/oasis/OASISContext.ml" *) + + open OASISGettext + + type level = + [ `Debug + | `Info + | `Warning + | `Error] + + type t = + { + quiet: bool; + info: bool; + debug: bool; + ignore_plugins: bool; + ignore_unknown_fields: bool; + printf: level -> string -> unit; + } + + let printf lvl str = + let beg = + match lvl with + | `Error -> s_ "E: " + | `Warning -> s_ "W: " + | `Info -> s_ "I: " + | `Debug -> s_ "D: " + in + prerr_endline (beg^str) + + let default = + ref + { + quiet = false; + info = false; + debug = false; + ignore_plugins = false; + ignore_unknown_fields = false; + printf = printf; + } + + let quiet = + {!default with quiet = true} + + + let args () = + ["-quiet", + Arg.Unit (fun () -> default := {!default with quiet = true}), + (s_ " Run quietly"); + + "-info", + Arg.Unit (fun () -> default := {!default with info = true}), + (s_ " Display information message"); + + + "-debug", + Arg.Unit (fun () -> default := {!default with debug = true}), + (s_ " Output debug message")] +end + +module OASISString = struct +(* # 1 "src/oasis/OASISString.ml" *) + + + + (** Various string utilities. + + Mostly inspired by extlib and batteries ExtString and BatString libraries. + + @author Sylvain Le Gall + *) + + let nsplitf str f = + if str = "" then + [] + else + let buf = Buffer.create 13 in + let lst = ref [] in + let push () = + lst := Buffer.contents buf :: !lst; + Buffer.clear buf + in + let str_len = String.length str in + for i = 0 to str_len - 1 do + if f str.[i] then + push () + else + Buffer.add_char buf str.[i] + done; + push (); + List.rev !lst + + (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the + separator. + *) + let nsplit str c = + nsplitf str ((=) c) + + let find ~what ?(offset=0) str = + let what_idx = ref 0 in + let str_idx = ref offset in + while !str_idx < String.length str && + !what_idx < String.length what do + if str.[!str_idx] = what.[!what_idx] then + incr what_idx + else + what_idx := 0; + incr str_idx + done; + if !what_idx <> String.length what then + raise Not_found + else + !str_idx - !what_idx + + let sub_start str len = + let str_len = String.length str in + if len >= str_len then + "" + else + String.sub str len (str_len - len) + + let sub_end ?(offset=0) str len = + let str_len = String.length str in + if len >= str_len then + "" + else + String.sub str 0 (str_len - len) + + let starts_with ~what ?(offset=0) str = + let what_idx = ref 0 in + let str_idx = ref offset in + let ok = ref true in + while !ok && + !str_idx < String.length str && + !what_idx < String.length what do + if str.[!str_idx] = what.[!what_idx] then + incr what_idx + else + ok := false; + incr str_idx + done; + if !what_idx = String.length what then + true + else + false + + let strip_starts_with ~what str = + if starts_with ~what str then + sub_start str (String.length what) + else + raise Not_found + + let ends_with ~what ?(offset=0) str = + let what_idx = ref ((String.length what) - 1) in + let str_idx = ref ((String.length str) - 1) in + let ok = ref true in + while !ok && + offset <= !str_idx && + 0 <= !what_idx do + if str.[!str_idx] = what.[!what_idx] then + decr what_idx + else + ok := false; + decr str_idx + done; + if !what_idx = -1 then + true + else + false + + let strip_ends_with ~what str = + if ends_with ~what str then + sub_end str (String.length what) + else + raise Not_found + + let replace_chars f s = + let buf = String.make (String.length s) 'X' in + for i = 0 to String.length s - 1 do + buf.[i] <- f s.[i] + done; + buf + +end + +module OASISUtils = struct +(* # 21 "src/oasis/OASISUtils.ml" *) + + open OASISGettext + + module MapString = Map.Make(String) + + let map_string_of_assoc assoc = + List.fold_left + (fun acc (k, v) -> MapString.add k v acc) + MapString.empty + assoc + + module SetString = Set.Make(String) + + let set_string_add_list st lst = + List.fold_left + (fun acc e -> SetString.add e acc) + st + lst + + let set_string_of_list = + set_string_add_list + SetString.empty + + + let compare_csl s1 s2 = + String.compare (String.lowercase s1) (String.lowercase s2) + + module HashStringCsl = + Hashtbl.Make + (struct + type t = string + + let equal s1 s2 = + (String.lowercase s1) = (String.lowercase s2) + + let hash s = + Hashtbl.hash (String.lowercase s) + end) + + let varname_of_string ?(hyphen='_') s = + if String.length s = 0 then + begin + invalid_arg "varname_of_string" + end + else + begin + let buf = + OASISString.replace_chars + (fun c -> + if ('a' <= c && c <= 'z') + || + ('A' <= c && c <= 'Z') + || + ('0' <= c && c <= '9') then + c + else + hyphen) + s; + in + let buf = + (* Start with a _ if digit *) + if '0' <= s.[0] && s.[0] <= '9' then + "_"^buf + else + buf + in + String.lowercase buf + end + + let varname_concat ?(hyphen='_') p s = + let what = String.make 1 hyphen in + let p = + try + OASISString.strip_ends_with ~what p + with Not_found -> + p + in + let s = + try + OASISString.strip_starts_with ~what s + with Not_found -> + s + in + p^what^s + + + let is_varname str = + str = varname_of_string str + + let failwithf fmt = Printf.ksprintf failwith fmt + +end + +module PropList = struct +(* # 21 "src/oasis/PropList.ml" *) + + open OASISGettext + + type name = string + + exception Not_set of name * string option + exception No_printer of name + exception Unknown_field of name * name + + let () = + Printexc.register_printer + (function + | Not_set (nm, Some rsn) -> + Some + (Printf.sprintf (f_ "Field '%s' is not set: %s") nm rsn) + | Not_set (nm, None) -> + Some + (Printf.sprintf (f_ "Field '%s' is not set") nm) + | No_printer nm -> + Some + (Printf.sprintf (f_ "No default printer for value %s") nm) + | Unknown_field (nm, schm) -> + Some + (Printf.sprintf (f_ "Field %s is not defined in schema %s") nm schm) + | _ -> + None) + + module Data = + struct + + type t = + (name, unit -> unit) Hashtbl.t + + let create () = + Hashtbl.create 13 + + let clear t = + Hashtbl.clear t + +(* # 71 "src/oasis/PropList.ml" *) + end + + module Schema = + struct + + type ('ctxt, 'extra) value = + { + get: Data.t -> string; + set: Data.t -> ?context:'ctxt -> string -> unit; + help: (unit -> string) option; + extra: 'extra; + } + + type ('ctxt, 'extra) t = + { + name: name; + fields: (name, ('ctxt, 'extra) value) Hashtbl.t; + order: name Queue.t; + name_norm: string -> string; + } + + let create ?(case_insensitive=false) nm = + { + name = nm; + fields = Hashtbl.create 13; + order = Queue.create (); + name_norm = + (if case_insensitive then + String.lowercase + else + fun s -> s); + } + + let add t nm set get extra help = + let key = + t.name_norm nm + in + + if Hashtbl.mem t.fields key then + failwith + (Printf.sprintf + (f_ "Field '%s' is already defined in schema '%s'") + nm t.name); + Hashtbl.add + t.fields + key + { + set = set; + get = get; + help = help; + extra = extra; + }; + Queue.add nm t.order + + let mem t nm = + Hashtbl.mem t.fields nm + + let find t nm = + try + Hashtbl.find t.fields (t.name_norm nm) + with Not_found -> + raise (Unknown_field (nm, t.name)) + + let get t data nm = + (find t nm).get data + + let set t data nm ?context x = + (find t nm).set + data + ?context + x + + let fold f acc t = + Queue.fold + (fun acc k -> + let v = + find t k + in + f acc k v.extra v.help) + acc + t.order + + let iter f t = + fold + (fun () -> f) + () + t + + let name t = + t.name + end + + module Field = + struct + + type ('ctxt, 'value, 'extra) t = + { + set: Data.t -> ?context:'ctxt -> 'value -> unit; + get: Data.t -> 'value; + sets: Data.t -> ?context:'ctxt -> string -> unit; + gets: Data.t -> string; + help: (unit -> string) option; + extra: 'extra; + } + + let new_id = + let last_id = + ref 0 + in + fun () -> incr last_id; !last_id + + let create ?schema ?name ?parse ?print ?default ?update ?help extra = + (* Default value container *) + let v = + ref None + in + + (* If name is not given, create unique one *) + let nm = + match name with + | Some s -> s + | None -> Printf.sprintf "_anon_%d" (new_id ()) + in + + (* Last chance to get a value: the default *) + let default () = + match default with + | Some d -> d + | None -> raise (Not_set (nm, Some (s_ "no default value"))) + in + + (* Get data *) + let get data = + (* Get value *) + try + (Hashtbl.find data nm) (); + match !v with + | Some x -> x + | None -> default () + with Not_found -> + default () + in + + (* Set data *) + let set data ?context x = + let x = + match update with + | Some f -> + begin + try + f ?context (get data) x + with Not_set _ -> + x + end + | None -> + x + in + Hashtbl.replace + data + nm + (fun () -> v := Some x) + in + + (* Parse string value, if possible *) + let parse = + match parse with + | Some f -> + f + | None -> + fun ?context s -> + failwith + (Printf.sprintf + (f_ "Cannot parse field '%s' when setting value %S") + nm + s) + in + + (* Set data, from string *) + let sets data ?context s = + set ?context data (parse ?context s) + in + + (* Output value as string, if possible *) + let print = + match print with + | Some f -> + f + | None -> + fun _ -> raise (No_printer nm) + in + + (* Get data, as a string *) + let gets data = + print (get data) + in + + begin + match schema with + | Some t -> + Schema.add t nm sets gets extra help + | None -> + () + end; + + { + set = set; + get = get; + sets = sets; + gets = gets; + help = help; + extra = extra; + } + + let fset data t ?context x = + t.set data ?context x + + let fget data t = + t.get data + + let fsets data t ?context s = + t.sets data ?context s + + let fgets data t = + t.gets data + + end + + module FieldRO = + struct + + let create ?schema ?name ?parse ?print ?default ?update ?help extra = + let fld = + Field.create ?schema ?name ?parse ?print ?default ?update ?help extra + in + fun data -> Field.fget data fld + + end +end + +module OASISMessage = struct +(* # 21 "src/oasis/OASISMessage.ml" *) + + + open OASISGettext + open OASISContext + + let generic_message ~ctxt lvl fmt = + let cond = + if ctxt.quiet then + false + else + match lvl with + | `Debug -> ctxt.debug + | `Info -> ctxt.info + | _ -> true + in + Printf.ksprintf + (fun str -> + if cond then + begin + ctxt.printf lvl str + end) + fmt + + let debug ~ctxt fmt = + generic_message ~ctxt `Debug fmt + + let info ~ctxt fmt = + generic_message ~ctxt `Info fmt + + let warning ~ctxt fmt = + generic_message ~ctxt `Warning fmt + + let error ~ctxt fmt = + generic_message ~ctxt `Error fmt + +end + +module OASISVersion = struct +(* # 21 "src/oasis/OASISVersion.ml" *) + + open OASISGettext + + + + type s = string + + type t = string + + type comparator = + | VGreater of t + | VGreaterEqual of t + | VEqual of t + | VLesser of t + | VLesserEqual of t + | VOr of comparator * comparator + | VAnd of comparator * comparator + + + (* Range of allowed characters *) + let is_digit c = + '0' <= c && c <= '9' + + let is_alpha c = + ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') + + let is_special = + function + | '.' | '+' | '-' | '~' -> true + | _ -> false + + let rec version_compare v1 v2 = + if v1 <> "" || v2 <> "" then + begin + (* Compare ascii string, using special meaning for version + * related char + *) + let val_ascii c = + if c = '~' then -1 + else if is_digit c then 0 + else if c = '\000' then 0 + else if is_alpha c then Char.code c + else (Char.code c) + 256 + in + + let len1 = String.length v1 in + let len2 = String.length v2 in + + let p = ref 0 in + + (** Compare ascii part *) + let compare_vascii () = + let cmp = ref 0 in + while !cmp = 0 && + !p < len1 && !p < len2 && + not (is_digit v1.[!p] && is_digit v2.[!p]) do + cmp := (val_ascii v1.[!p]) - (val_ascii v2.[!p]); + incr p + done; + if !cmp = 0 && !p < len1 && !p = len2 then + val_ascii v1.[!p] + else if !cmp = 0 && !p = len1 && !p < len2 then + - (val_ascii v2.[!p]) + else + !cmp + in + + (** Compare digit part *) + let compare_digit () = + let extract_int v p = + let start_p = !p in + while !p < String.length v && is_digit v.[!p] do + incr p + done; + let substr = + String.sub v !p ((String.length v) - !p) + in + let res = + match String.sub v start_p (!p - start_p) with + | "" -> 0 + | s -> int_of_string s + in + res, substr + in + let i1, tl1 = extract_int v1 (ref !p) in + let i2, tl2 = extract_int v2 (ref !p) in + i1 - i2, tl1, tl2 + in + + match compare_vascii () with + | 0 -> + begin + match compare_digit () with + | 0, tl1, tl2 -> + if tl1 <> "" && is_digit tl1.[0] then + 1 + else if tl2 <> "" && is_digit tl2.[0] then + -1 + else + version_compare tl1 tl2 + | n, _, _ -> + n + end + | n -> + n + end + else + begin + 0 + end + + + let version_of_string str = str + + let string_of_version t = t + + let chop t = + try + let pos = + String.rindex t '.' + in + String.sub t 0 pos + with Not_found -> + t + + let rec comparator_apply v op = + match op with + | VGreater cv -> + (version_compare v cv) > 0 + | VGreaterEqual cv -> + (version_compare v cv) >= 0 + | VLesser cv -> + (version_compare v cv) < 0 + | VLesserEqual cv -> + (version_compare v cv) <= 0 + | VEqual cv -> + (version_compare v cv) = 0 + | VOr (op1, op2) -> + (comparator_apply v op1) || (comparator_apply v op2) + | VAnd (op1, op2) -> + (comparator_apply v op1) && (comparator_apply v op2) + + let rec string_of_comparator = + function + | VGreater v -> "> "^(string_of_version v) + | VEqual v -> "= "^(string_of_version v) + | VLesser v -> "< "^(string_of_version v) + | VGreaterEqual v -> ">= "^(string_of_version v) + | VLesserEqual v -> "<= "^(string_of_version v) + | VOr (c1, c2) -> + (string_of_comparator c1)^" || "^(string_of_comparator c2) + | VAnd (c1, c2) -> + (string_of_comparator c1)^" && "^(string_of_comparator c2) + + let rec varname_of_comparator = + let concat p v = + OASISUtils.varname_concat + p + (OASISUtils.varname_of_string + (string_of_version v)) + in + function + | VGreater v -> concat "gt" v + | VLesser v -> concat "lt" v + | VEqual v -> concat "eq" v + | VGreaterEqual v -> concat "ge" v + | VLesserEqual v -> concat "le" v + | VOr (c1, c2) -> + (varname_of_comparator c1)^"_or_"^(varname_of_comparator c2) + | VAnd (c1, c2) -> + (varname_of_comparator c1)^"_and_"^(varname_of_comparator c2) + + let version_0_3_or_after t = + comparator_apply t (VGreaterEqual (string_of_version "0.3")) + +end + +module OASISLicense = struct +(* # 21 "src/oasis/OASISLicense.ml" *) + + (** License for _oasis fields + @author Sylvain Le Gall + *) + + + + type license = string + + type license_exception = string + + type license_version = + | Version of OASISVersion.t + | VersionOrLater of OASISVersion.t + | NoVersion + + + type license_dep_5_unit = + { + license: license; + excption: license_exception option; + version: license_version; + } + + + type license_dep_5 = + | DEP5Unit of license_dep_5_unit + | DEP5Or of license_dep_5 list + | DEP5And of license_dep_5 list + + + type t = + | DEP5License of license_dep_5 + | OtherLicense of string (* URL *) + + +end + +module OASISExpr = struct +(* # 21 "src/oasis/OASISExpr.ml" *) + + + + open OASISGettext + + type test = string + + type flag = string + + type t = + | EBool of bool + | ENot of t + | EAnd of t * t + | EOr of t * t + | EFlag of flag + | ETest of test * string + + + type 'a choices = (t * 'a) list + + let eval var_get t = + let rec eval' = + function + | EBool b -> + b + + | ENot e -> + not (eval' e) + + | EAnd (e1, e2) -> + (eval' e1) && (eval' e2) + + | EOr (e1, e2) -> + (eval' e1) || (eval' e2) + + | EFlag nm -> + let v = + var_get nm + in + assert(v = "true" || v = "false"); + (v = "true") + + | ETest (nm, vl) -> + let v = + var_get nm + in + (v = vl) + in + eval' t + + let choose ?printer ?name var_get lst = + let rec choose_aux = + function + | (cond, vl) :: tl -> + if eval var_get cond then + vl + else + choose_aux tl + | [] -> + let str_lst = + if lst = [] then + s_ "" + else + String.concat + (s_ ", ") + (List.map + (fun (cond, vl) -> + match printer with + | Some p -> p vl + | None -> s_ "") + lst) + in + match name with + | Some nm -> + failwith + (Printf.sprintf + (f_ "No result for the choice list '%s': %s") + nm str_lst) + | None -> + failwith + (Printf.sprintf + (f_ "No result for a choice list: %s") + str_lst) + in + choose_aux (List.rev lst) + +end + +module OASISTypes = struct +(* # 21 "src/oasis/OASISTypes.ml" *) + + + + + type name = string + type package_name = string + type url = string + type unix_dirname = string + type unix_filename = string + type host_dirname = string + type host_filename = string + type prog = string + type arg = string + type args = string list + type command_line = (prog * arg list) + + type findlib_name = string + type findlib_full = string + + type compiled_object = + | Byte + | Native + | Native_object + | Bytecode_object + | Best + + + type dependency = + | FindlibPackage of findlib_full * OASISVersion.comparator option + | InternalLibrary of name + + + type tool = + | ExternalTool of name + | InternalExecutable of name + + + type vcs = + | Darcs + | Git + | Svn + | Cvs + | Hg + | Bzr + | Arch + | Monotone + | OtherVCS of url + + + type plugin_kind = + [ `Configure + | `Build + | `Doc + | `Test + | `Install + | `Extra + ] + + type plugin_data_purpose = + [ `Configure + | `Build + | `Install + | `Clean + | `Distclean + | `Install + | `Uninstall + | `Test + | `Doc + | `Extra + | `Other of string + ] + + type 'a plugin = 'a * name * OASISVersion.t option + + type all_plugin = plugin_kind plugin + + type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list + +(* # 104 "src/oasis/OASISTypes.ml" *) + + type 'a conditional = 'a OASISExpr.choices + + type custom = + { + pre_command: (command_line option) conditional; + post_command: (command_line option) conditional; + } + + + type common_section = + { + cs_name: name; + cs_data: PropList.Data.t; + cs_plugin_data: plugin_data; + } + + + type build_section = + { + bs_build: bool conditional; + bs_install: bool conditional; + bs_path: unix_dirname; + bs_compiled_object: compiled_object; + bs_build_depends: dependency list; + bs_build_tools: tool list; + bs_c_sources: unix_filename list; + bs_data_files: (unix_filename * unix_filename option) list; + bs_ccopt: args conditional; + bs_cclib: args conditional; + bs_dlllib: args conditional; + bs_dllpath: args conditional; + bs_byteopt: args conditional; + bs_nativeopt: args conditional; + } + + + type library = + { + lib_modules: string list; + lib_pack: bool; + lib_internal_modules: string list; + lib_findlib_parent: findlib_name option; + lib_findlib_name: findlib_name option; + lib_findlib_containers: findlib_name list; + } + + + type object_ = + { + obj_modules: string list; + obj_findlib_fullname: findlib_name list option; + } + + type executable = + { + exec_custom: bool; + exec_main_is: unix_filename; + } + + type flag = + { + flag_description: string option; + flag_default: bool conditional; + } + + type source_repository = + { + src_repo_type: vcs; + src_repo_location: url; + src_repo_browser: url option; + src_repo_module: string option; + src_repo_branch: string option; + src_repo_tag: string option; + src_repo_subdir: unix_filename option; + } + + type test = + { + test_type: [`Test] plugin; + test_command: command_line conditional; + test_custom: custom; + test_working_directory: unix_filename option; + test_run: bool conditional; + test_tools: tool list; + } + + type doc_format = + | HTML of unix_filename + | DocText + | PDF + | PostScript + | Info of unix_filename + | DVI + | OtherDoc + + + type doc = + { + doc_type: [`Doc] plugin; + doc_custom: custom; + doc_build: bool conditional; + doc_install: bool conditional; + doc_install_dir: unix_filename; + doc_title: string; + doc_authors: string list; + doc_abstract: string option; + doc_format: doc_format; + doc_data_files: (unix_filename * unix_filename option) list; + doc_build_tools: tool list; + } + + type section = + | Library of common_section * build_section * library + | Object of common_section * build_section * object_ + | Executable of common_section * build_section * executable + | Flag of common_section * flag + | SrcRepo of common_section * source_repository + | Test of common_section * test + | Doc of common_section * doc + + + type section_kind = + [ `Library | `Object | `Executable | `Flag | `SrcRepo | `Test | `Doc ] + + type package = + { + oasis_version: OASISVersion.t; + ocaml_version: OASISVersion.comparator option; + findlib_version: OASISVersion.comparator option; + name: package_name; + version: OASISVersion.t; + license: OASISLicense.t; + license_file: unix_filename option; + copyrights: string list; + maintainers: string list; + authors: string list; + homepage: url option; + synopsis: string; + description: string option; + categories: url list; + + conf_type: [`Configure] plugin; + conf_custom: custom; + + build_type: [`Build] plugin; + build_custom: custom; + + install_type: [`Install] plugin; + install_custom: custom; + uninstall_custom: custom; + + clean_custom: custom; + distclean_custom: custom; + + files_ab: unix_filename list; + sections: section list; + plugins: [`Extra] plugin list; + schema_data: PropList.Data.t; + plugin_data: plugin_data; + } + +end + +module OASISUnixPath = struct +(* # 21 "src/oasis/OASISUnixPath.ml" *) + + type unix_filename = string + type unix_dirname = string + + type host_filename = string + type host_dirname = string + + let current_dir_name = "." + + let parent_dir_name = ".." + + let is_current_dir fn = + fn = current_dir_name || fn = "" + + let concat f1 f2 = + if is_current_dir f1 then + f2 + else + let f1' = + try OASISString.strip_ends_with ~what:"/" f1 with Not_found -> f1 + in + f1'^"/"^f2 + + let make = + function + | hd :: tl -> + List.fold_left + (fun f p -> concat f p) + hd + tl + | [] -> + invalid_arg "OASISUnixPath.make" + + let dirname f = + try + String.sub f 0 (String.rindex f '/') + with Not_found -> + current_dir_name + + let basename f = + try + let pos_start = + (String.rindex f '/') + 1 + in + String.sub f pos_start ((String.length f) - pos_start) + with Not_found -> + f + + let chop_extension f = + try + let last_dot = + String.rindex f '.' + in + let sub = + String.sub f 0 last_dot + in + try + let last_slash = + String.rindex f '/' + in + if last_slash < last_dot then + sub + else + f + with Not_found -> + sub + + with Not_found -> + f + + let capitalize_file f = + let dir = dirname f in + let base = basename f in + concat dir (String.capitalize base) + + let uncapitalize_file f = + let dir = dirname f in + let base = basename f in + concat dir (String.uncapitalize base) + +end + +module OASISHostPath = struct +(* # 21 "src/oasis/OASISHostPath.ml" *) + + + open Filename + + module Unix = OASISUnixPath + + let make = + function + | [] -> + invalid_arg "OASISHostPath.make" + | hd :: tl -> + List.fold_left Filename.concat hd tl + + let of_unix ufn = + if Sys.os_type = "Unix" then + ufn + else + make + (List.map + (fun p -> + if p = Unix.current_dir_name then + current_dir_name + else if p = Unix.parent_dir_name then + parent_dir_name + else + p) + (OASISString.nsplit ufn '/')) + + +end + +module OASISSection = struct +(* # 21 "src/oasis/OASISSection.ml" *) + + open OASISTypes + + let section_kind_common = + function + | Library (cs, _, _) -> + `Library, cs + | Object (cs, _, _) -> + `Object, cs + | Executable (cs, _, _) -> + `Executable, cs + | Flag (cs, _) -> + `Flag, cs + | SrcRepo (cs, _) -> + `SrcRepo, cs + | Test (cs, _) -> + `Test, cs + | Doc (cs, _) -> + `Doc, cs + + let section_common sct = + snd (section_kind_common sct) + + let section_common_set cs = + function + | Library (_, bs, lib) -> Library (cs, bs, lib) + | Object (_, bs, obj) -> Object (cs, bs, obj) + | Executable (_, bs, exec) -> Executable (cs, bs, exec) + | Flag (_, flg) -> Flag (cs, flg) + | SrcRepo (_, src_repo) -> SrcRepo (cs, src_repo) + | Test (_, tst) -> Test (cs, tst) + | Doc (_, doc) -> Doc (cs, doc) + + (** Key used to identify section + *) + let section_id sct = + let k, cs = + section_kind_common sct + in + k, cs.cs_name + + let string_of_section sct = + let k, nm = + section_id sct + in + (match k with + | `Library -> "library" + | `Object -> "object" + | `Executable -> "executable" + | `Flag -> "flag" + | `SrcRepo -> "src repository" + | `Test -> "test" + | `Doc -> "doc") + ^" "^nm + + let section_find id scts = + List.find + (fun sct -> id = section_id sct) + scts + + module CSection = + struct + type t = section + + let id = section_id + + let compare t1 t2 = + compare (id t1) (id t2) + + let equal t1 t2 = + (id t1) = (id t2) + + let hash t = + Hashtbl.hash (id t) + end + + module MapSection = Map.Make(CSection) + module SetSection = Set.Make(CSection) + +end + +module OASISBuildSection = struct +(* # 21 "src/oasis/OASISBuildSection.ml" *) + +end + +module OASISExecutable = struct +(* # 21 "src/oasis/OASISExecutable.ml" *) + + open OASISTypes + + let unix_exec_is (cs, bs, exec) is_native ext_dll suffix_program = + let dir = + OASISUnixPath.concat + bs.bs_path + (OASISUnixPath.dirname exec.exec_main_is) + in + let is_native_exec = + match bs.bs_compiled_object with + | Native -> true + | Native_object -> false + | Bytecode_object -> false + | Best -> is_native () + | Byte -> false + in + + OASISUnixPath.concat + dir + (cs.cs_name^(suffix_program ())), + + if not is_native_exec && + not exec.exec_custom && + bs.bs_c_sources <> [] then + Some (dir^"/dll"^cs.cs_name^"_stubs"^(ext_dll ())) + else + None + +end + +module OASISLibrary = struct +(* # 21 "src/oasis/OASISLibrary.ml" *) + + open OASISTypes + open OASISUtils + open OASISGettext + open OASISSection + + (* Look for a module file, considering capitalization or not. *) + let find_module source_file_exists bs modul = + let possible_base_fn = + List.map + (OASISUnixPath.concat bs.bs_path) + [modul; + OASISUnixPath.uncapitalize_file modul; + OASISUnixPath.capitalize_file modul] + in + (* TODO: we should be able to be able to determine the source for every + * files. Hence we should introduce a Module(source: fn) for the fields + * Modules and InternalModules + *) + List.fold_left + (fun acc base_fn -> + match acc with + | `No_sources _ -> + begin + let file_found = + List.fold_left + (fun acc ext -> + if source_file_exists (base_fn^ext) then + (base_fn^ext) :: acc + else + acc) + [] + [".ml"; ".mli"; ".mll"; ".mly"] + in + match file_found with + | [] -> + acc + | lst -> + `Sources (base_fn, lst) + end + | `Sources _ -> + acc) + (`No_sources possible_base_fn) + possible_base_fn + + let source_unix_files ~ctxt (cs, bs, lib) source_file_exists = + List.fold_left + (fun acc modul -> + match find_module source_file_exists bs modul with + | `Sources (base_fn, lst) -> + (base_fn, lst) :: acc + | `No_sources _ -> + OASISMessage.warning + ~ctxt + (f_ "Cannot find source file matching \ + module '%s' in library %s") + modul cs.cs_name; + acc) + [] + (lib.lib_modules @ lib.lib_internal_modules) + + let generated_unix_files + ~ctxt + ~is_native + ~has_native_dynlink + ~ext_lib + ~ext_dll + ~source_file_exists + (cs, bs, lib) = + + let find_modules lst ext = + let find_module modul = + match find_module source_file_exists bs modul with + | `Sources (base_fn, _) -> + [base_fn] + | `No_sources lst -> + OASISMessage.warning + ~ctxt + (f_ "Cannot find source file matching \ + module '%s' in library %s") + modul cs.cs_name; + lst + in + List.map + (fun nm -> + List.map + (fun base_fn -> base_fn ^"."^ext) + (find_module nm)) + lst + in + + (* The headers that should be compiled along *) + let headers = + if lib.lib_pack then + [] + else + find_modules + lib.lib_modules + "cmi" + in + + (* The .cmx that be compiled along *) + let cmxs = + let should_be_built = + (not lib.lib_pack) && (* Do not install .cmx packed submodules *) + match bs.bs_compiled_object with + | Native -> true + | Native_object -> false + | Bytecode_object -> false + | Best -> is_native + | Byte -> false + in + if should_be_built then + find_modules + (lib.lib_modules @ lib.lib_internal_modules) + "cmx" + else + [] + in + + let acc_nopath = + [] + in + + (* Compute what libraries should be built *) + let acc_nopath = + (* Add the packed header file if required *) + let add_pack_header acc = + if lib.lib_pack then + [cs.cs_name^".cmi"] :: acc + else + acc + in + let byte acc = + add_pack_header ([cs.cs_name^".cma"] :: acc) + in + let native acc = + let acc = + add_pack_header + (if has_native_dynlink then + [cs.cs_name^".cmxs"] :: acc + else acc) + in + [cs.cs_name^".cmxa"] :: [cs.cs_name^ext_lib] :: acc + in + match bs.bs_compiled_object with + | Native | Native_object -> + byte (native acc_nopath) + | Best when is_native -> + byte (native acc_nopath) + | Byte | Bytecode_object | Best -> + byte acc_nopath + in + + (* Add C library to be built *) + let acc_nopath = + if bs.bs_c_sources <> [] then + begin + ["lib"^cs.cs_name^"_stubs"^ext_lib] + :: + ["dll"^cs.cs_name^"_stubs"^ext_dll] + :: + acc_nopath + end + else + acc_nopath + in + + (* All the files generated *) + List.rev_append + (List.rev_map + (List.rev_map + (OASISUnixPath.concat bs.bs_path)) + acc_nopath) + (headers @ cmxs) + +end + +module OASISObject = struct +(* # 21 "src/oasis/OASISObject.ml" *) + + open OASISTypes + open OASISGettext + + let source_unix_files ~ctxt (cs, bs, obj) source_file_exists = + List.fold_left + (fun acc modul -> + match OASISLibrary.find_module source_file_exists bs modul with + | `Sources (base_fn, lst) -> + (base_fn, lst) :: acc + | `No_sources _ -> + OASISMessage.warning + ~ctxt + (f_ "Cannot find source file matching \ + module '%s' in object %s") + modul cs.cs_name; + acc) + [] + obj.obj_modules + + + let generated_unix_files + ~ctxt + ~is_native + ~source_file_exists + (cs, bs, obj) = + + let find_module ext modul = + match OASISLibrary.find_module source_file_exists bs modul with + | `Sources (base_fn, _) -> [base_fn ^ ext] + | `No_sources lst -> + OASISMessage.warning + ~ctxt + (f_ "Cannot find source file matching \ + module '%s' in object %s") + modul cs.cs_name ; + lst + in + + let header, byte, native, c_object, f = + match obj.obj_modules with + | [ m ] -> (find_module ".cmi" m, + find_module ".cmo" m, + find_module ".cmx" m, + find_module ".o" m, + fun x -> x) + | _ -> ([cs.cs_name ^ ".cmi"], + [cs.cs_name ^ ".cmo"], + [cs.cs_name ^ ".cmx"], + [cs.cs_name ^ ".o"], + OASISUnixPath.concat bs.bs_path) + in + List.map (List.map f) ( + match bs.bs_compiled_object with + | Native | Native_object -> + native :: c_object :: byte :: header :: [] + | Best when is_native -> + native :: c_object :: byte :: header :: [] + | Byte | Bytecode_object | Best -> + byte :: header :: []) + +end + +module OASISFindlib = struct +(* # 21 "src/oasis/OASISFindlib.ml" *) + + + open OASISTypes + open OASISUtils + open OASISGettext + open OASISSection + + type library_name = name + type findlib_part_name = name + type 'a map_of_findlib_part_name = 'a OASISUtils.MapString.t + + exception InternalLibraryNotFound of library_name + exception FindlibPackageNotFound of findlib_name + + type group_t = + | Container of findlib_name * group_t list + | Package of (findlib_name * + common_section * + build_section * + [`Library of library | `Object of object_] * + group_t list) + + type data = common_section * + build_section * + [`Library of library | `Object of object_] + type tree = + | Node of (data option) * (tree MapString.t) + | Leaf of data + + let findlib_mapping pkg = + (* Map from library name to either full findlib name or parts + parent. *) + let fndlb_parts_of_lib_name = + let fndlb_parts cs lib = + let name = + match lib.lib_findlib_name with + | Some nm -> nm + | None -> cs.cs_name + in + let name = + String.concat "." (lib.lib_findlib_containers @ [name]) + in + name + in + List.fold_left + (fun mp -> + function + | Library (cs, _, lib) -> + begin + let lib_name = cs.cs_name in + let fndlb_parts = fndlb_parts cs lib in + if MapString.mem lib_name mp then + failwithf + (f_ "The library name '%s' is used more than once.") + lib_name; + match lib.lib_findlib_parent with + | Some lib_name_parent -> + MapString.add + lib_name + (`Unsolved (lib_name_parent, fndlb_parts)) + mp + | None -> + MapString.add + lib_name + (`Solved fndlb_parts) + mp + end + + | Object (cs, _, obj) -> + begin + let obj_name = cs.cs_name in + if MapString.mem obj_name mp then + failwithf + (f_ "The object name '%s' is used more than once.") + obj_name; + let findlib_full_name = match obj.obj_findlib_fullname with + | Some ns -> String.concat "." ns + | None -> obj_name + in + MapString.add + obj_name + (`Solved findlib_full_name) + mp + end + + | Executable _ | Test _ | Flag _ | SrcRepo _ | Doc _ -> + mp) + MapString.empty + pkg.sections + in + + (* Solve the above graph to be only library name to full findlib name. *) + let fndlb_name_of_lib_name = + let rec solve visited mp lib_name lib_name_child = + if SetString.mem lib_name visited then + failwithf + (f_ "Library '%s' is involved in a cycle \ + with regard to findlib naming.") + lib_name; + let visited = SetString.add lib_name visited in + try + match MapString.find lib_name mp with + | `Solved fndlb_nm -> + fndlb_nm, mp + | `Unsolved (lib_nm_parent, post_fndlb_nm) -> + let pre_fndlb_nm, mp = + solve visited mp lib_nm_parent lib_name + in + let fndlb_nm = pre_fndlb_nm^"."^post_fndlb_nm in + fndlb_nm, MapString.add lib_name (`Solved fndlb_nm) mp + with Not_found -> + failwithf + (f_ "Library '%s', which is defined as the findlib parent of \ + library '%s', doesn't exist.") + lib_name lib_name_child + in + let mp = + MapString.fold + (fun lib_name status mp -> + match status with + | `Solved _ -> + (* Solved initialy, no need to go further *) + mp + | `Unsolved _ -> + let _, mp = solve SetString.empty mp lib_name "" in + mp) + fndlb_parts_of_lib_name + fndlb_parts_of_lib_name + in + MapString.map + (function + | `Solved fndlb_nm -> fndlb_nm + | `Unsolved _ -> assert false) + mp + in + + (* Convert an internal library name to a findlib name. *) + let findlib_name_of_library_name lib_nm = + try + MapString.find lib_nm fndlb_name_of_lib_name + with Not_found -> + raise (InternalLibraryNotFound lib_nm) + in + + (* Add a library to the tree. + *) + let add sct mp = + let fndlb_fullname = + let cs, _, _ = sct in + let lib_name = cs.cs_name in + findlib_name_of_library_name lib_name + in + let rec add_children nm_lst (children : tree MapString.t) = + match nm_lst with + | (hd :: tl) -> + begin + let node = + try + add_node tl (MapString.find hd children) + with Not_found -> + (* New node *) + new_node tl + in + MapString.add hd node children + end + | [] -> + (* Should not have a nameless library. *) + assert false + and add_node tl node = + if tl = [] then + begin + match node with + | Node (None, children) -> + Node (Some sct, children) + | Leaf (cs', _, _) | Node (Some (cs', _, _), _) -> + (* TODO: allow to merge Package, i.e. + * archive(byte) = "foo.cma foo_init.cmo" + *) + let cs, _, _ = sct in + failwithf + (f_ "Library '%s' and '%s' have the same findlib name '%s'") + cs.cs_name cs'.cs_name fndlb_fullname + end + else + begin + match node with + | Leaf data -> + Node (Some data, add_children tl MapString.empty) + | Node (data_opt, children) -> + Node (data_opt, add_children tl children) + end + and new_node = + function + | [] -> + Leaf sct + | hd :: tl -> + Node (None, MapString.add hd (new_node tl) MapString.empty) + in + add_children (OASISString.nsplit fndlb_fullname '.') mp + in + + let rec group_of_tree mp = + MapString.fold + (fun nm node acc -> + let cur = + match node with + | Node (Some (cs, bs, lib), children) -> + Package (nm, cs, bs, lib, group_of_tree children) + | Node (None, children) -> + Container (nm, group_of_tree children) + | Leaf (cs, bs, lib) -> + Package (nm, cs, bs, lib, []) + in + cur :: acc) + mp [] + in + + let group_mp = + List.fold_left + (fun mp -> + function + | Library (cs, bs, lib) -> + add (cs, bs, `Library lib) mp + | Object (cs, bs, obj) -> + add (cs, bs, `Object obj) mp + | _ -> + mp) + MapString.empty + pkg.sections + in + + let groups = + group_of_tree group_mp + in + + let library_name_of_findlib_name = + Lazy.lazy_from_fun + (fun () -> + (* Revert findlib_name_of_library_name. *) + MapString.fold + (fun k v mp -> MapString.add v k mp) + fndlb_name_of_lib_name + MapString.empty) + in + let library_name_of_findlib_name fndlb_nm = + try + MapString.find fndlb_nm (Lazy.force library_name_of_findlib_name) + with Not_found -> + raise (FindlibPackageNotFound fndlb_nm) + in + + groups, + findlib_name_of_library_name, + library_name_of_findlib_name + + let findlib_of_group = + function + | Container (fndlb_nm, _) + | Package (fndlb_nm, _, _, _, _) -> fndlb_nm + + let root_of_group grp = + let rec root_lib_aux = + (* We do a DFS in the group. *) + function + | Container (_, children) -> + List.fold_left + (fun res grp -> + if res = None then + root_lib_aux grp + else + res) + None + children + | Package (_, cs, bs, lib, _) -> + Some (cs, bs, lib) + in + match root_lib_aux grp with + | Some res -> + res + | None -> + failwithf + (f_ "Unable to determine root library of findlib library '%s'") + (findlib_of_group grp) + +end + +module OASISFlag = struct +(* # 21 "src/oasis/OASISFlag.ml" *) + +end + +module OASISPackage = struct +(* # 21 "src/oasis/OASISPackage.ml" *) + +end + +module OASISSourceRepository = struct +(* # 21 "src/oasis/OASISSourceRepository.ml" *) + +end + +module OASISTest = struct +(* # 21 "src/oasis/OASISTest.ml" *) + +end + +module OASISDocument = struct +(* # 21 "src/oasis/OASISDocument.ml" *) + +end + +module OASISExec = struct +(* # 21 "src/oasis/OASISExec.ml" *) + + open OASISGettext + open OASISUtils + open OASISMessage + + (* TODO: I don't like this quote, it is there because $(rm) foo expands to + * 'rm -f' foo... + *) + let run ~ctxt ?f_exit_code ?(quote=true) cmd args = + let cmd = + if quote then + if Sys.os_type = "Win32" then + if String.contains cmd ' ' then + (* Double the 1st double quote... win32... sigh *) + "\""^(Filename.quote cmd) + else + cmd + else + Filename.quote cmd + else + cmd + in + let cmdline = + String.concat " " (cmd :: args) + in + info ~ctxt (f_ "Running command '%s'") cmdline; + match f_exit_code, Sys.command cmdline with + | None, 0 -> () + | None, i -> + failwithf + (f_ "Command '%s' terminated with error code %d") + cmdline i + | Some f, i -> + f i + + let run_read_output ~ctxt ?f_exit_code cmd args = + let fn = + Filename.temp_file "oasis-" ".txt" + in + try + begin + let () = + run ~ctxt ?f_exit_code cmd (args @ [">"; Filename.quote fn]) + in + let chn = + open_in fn + in + let routput = + ref [] + in + begin + try + while true do + routput := (input_line chn) :: !routput + done + with End_of_file -> + () + end; + close_in chn; + Sys.remove fn; + List.rev !routput + end + with e -> + (try Sys.remove fn with _ -> ()); + raise e + + let run_read_one_line ~ctxt ?f_exit_code cmd args = + match run_read_output ~ctxt ?f_exit_code cmd args with + | [fst] -> + fst + | lst -> + failwithf + (f_ "Command return unexpected output %S") + (String.concat "\n" lst) +end + +module OASISFileUtil = struct +(* # 21 "src/oasis/OASISFileUtil.ml" *) + + open OASISGettext + + let file_exists_case fn = + let dirname = Filename.dirname fn in + let basename = Filename.basename fn in + if Sys.file_exists dirname then + if basename = Filename.current_dir_name then + true + else + List.mem + basename + (Array.to_list (Sys.readdir dirname)) + else + false + + let find_file ?(case_sensitive=true) paths exts = + + (* Cardinal product of two list *) + let ( * ) lst1 lst2 = + List.flatten + (List.map + (fun a -> + List.map + (fun b -> a,b) + lst2) + lst1) + in + + let rec combined_paths lst = + match lst with + | p1 :: p2 :: tl -> + let acc = + (List.map + (fun (a,b) -> Filename.concat a b) + (p1 * p2)) + in + combined_paths (acc :: tl) + | [e] -> + e + | [] -> + [] + in + + let alternatives = + List.map + (fun (p,e) -> + if String.length e > 0 && e.[0] <> '.' then + p ^ "." ^ e + else + p ^ e) + ((combined_paths paths) * exts) + in + List.find + (if case_sensitive then + file_exists_case + else + Sys.file_exists) + alternatives + + let which ~ctxt prg = + let path_sep = + match Sys.os_type with + | "Win32" -> + ';' + | _ -> + ':' + in + let path_lst = OASISString.nsplit (Sys.getenv "PATH") path_sep in + let exec_ext = + match Sys.os_type with + | "Win32" -> + "" :: (OASISString.nsplit (Sys.getenv "PATHEXT") path_sep) + | _ -> + [""] + in + find_file ~case_sensitive:false [path_lst; [prg]] exec_ext + + (**/**) + let rec fix_dir dn = + (* Windows hack because Sys.file_exists "src\\" = false when + * Sys.file_exists "src" = true + *) + let ln = + String.length dn + in + if Sys.os_type = "Win32" && ln > 0 && dn.[ln - 1] = '\\' then + fix_dir (String.sub dn 0 (ln - 1)) + else + dn + + let q = Filename.quote + (**/**) + + let cp ~ctxt ?(recurse=false) src tgt = + if recurse then + match Sys.os_type with + | "Win32" -> + OASISExec.run ~ctxt + "xcopy" [q src; q tgt; "/E"] + | _ -> + OASISExec.run ~ctxt + "cp" ["-r"; q src; q tgt] + else + OASISExec.run ~ctxt + (match Sys.os_type with + | "Win32" -> "copy" + | _ -> "cp") + [q src; q tgt] + + let mkdir ~ctxt tgt = + OASISExec.run ~ctxt + (match Sys.os_type with + | "Win32" -> "md" + | _ -> "mkdir") + [q tgt] + + let rec mkdir_parent ~ctxt f tgt = + let tgt = + fix_dir tgt + in + if Sys.file_exists tgt then + begin + if not (Sys.is_directory tgt) then + OASISUtils.failwithf + (f_ "Cannot create directory '%s', a file of the same name already \ + exists") + tgt + end + else + begin + mkdir_parent ~ctxt f (Filename.dirname tgt); + if not (Sys.file_exists tgt) then + begin + f tgt; + mkdir ~ctxt tgt + end + end + + let rmdir ~ctxt tgt = + if Sys.readdir tgt = [||] then + begin + match Sys.os_type with + | "Win32" -> + OASISExec.run ~ctxt "rd" [q tgt] + | _ -> + OASISExec.run ~ctxt "rm" ["-r"; q tgt] + end + + let glob ~ctxt fn = + let basename = + Filename.basename fn + in + if String.length basename >= 2 && + basename.[0] = '*' && + basename.[1] = '.' then + begin + let ext_len = + (String.length basename) - 2 + in + let ext = + String.sub basename 2 ext_len + in + let dirname = + Filename.dirname fn + in + Array.fold_left + (fun acc fn -> + try + let fn_ext = + String.sub + fn + ((String.length fn) - ext_len) + ext_len + in + if fn_ext = ext then + (Filename.concat dirname fn) :: acc + else + acc + with Invalid_argument _ -> + acc) + [] + (Sys.readdir dirname) + end + else + begin + if file_exists_case fn then + [fn] + else + [] + end +end + + +# 2257 "setup.ml" +module BaseEnvLight = struct +(* # 21 "src/base/BaseEnvLight.ml" *) + + module MapString = Map.Make(String) + + type t = string MapString.t + + let default_filename = + Filename.concat + (Sys.getcwd ()) + "setup.data" + + let load ?(allow_empty=false) ?(filename=default_filename) () = + if Sys.file_exists filename then + begin + let chn = + open_in_bin filename + in + let st = + Stream.of_channel chn + in + let line = + ref 1 + in + let st_line = + Stream.from + (fun _ -> + try + match Stream.next st with + | '\n' -> incr line; Some '\n' + | c -> Some c + with Stream.Failure -> None) + in + let lexer = + Genlex.make_lexer ["="] st_line + in + let rec read_file mp = + match Stream.npeek 3 lexer with + | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> + Stream.junk lexer; + Stream.junk lexer; + Stream.junk lexer; + read_file (MapString.add nm value mp) + | [] -> + mp + | _ -> + failwith + (Printf.sprintf + "Malformed data file '%s' line %d" + filename !line) + in + let mp = + read_file MapString.empty + in + close_in chn; + mp + end + else if allow_empty then + begin + MapString.empty + end + else + begin + failwith + (Printf.sprintf + "Unable to load environment, the file '%s' doesn't exist." + filename) + end + + let var_get name env = + let rec var_expand str = + let buff = + Buffer.create ((String.length str) * 2) + in + Buffer.add_substitute + buff + (fun var -> + try + var_expand (MapString.find var env) + with Not_found -> + failwith + (Printf.sprintf + "No variable %s defined when trying to expand %S." + var + str)) + str; + Buffer.contents buff + in + var_expand (MapString.find name env) + + let var_choose lst env = + OASISExpr.choose + (fun nm -> var_get nm env) + lst +end + + +# 2355 "setup.ml" +module BaseContext = struct +(* # 21 "src/base/BaseContext.ml" *) + + open OASISContext + + let args = args + + let default = default + +end + +module BaseMessage = struct +(* # 21 "src/base/BaseMessage.ml" *) + + (** Message to user, overrid for Base + @author Sylvain Le Gall + *) + open OASISMessage + open BaseContext + + let debug fmt = debug ~ctxt:!default fmt + + let info fmt = info ~ctxt:!default fmt + + let warning fmt = warning ~ctxt:!default fmt + + let error fmt = error ~ctxt:!default fmt + +end + +module BaseEnv = struct +(* # 21 "src/base/BaseEnv.ml" *) + + open OASISGettext + open OASISUtils + open PropList + + module MapString = BaseEnvLight.MapString + + type origin_t = + | ODefault + | OGetEnv + | OFileLoad + | OCommandLine + + type cli_handle_t = + | CLINone + | CLIAuto + | CLIWith + | CLIEnable + | CLIUser of (Arg.key * Arg.spec * Arg.doc) list + + type definition_t = + { + hide: bool; + dump: bool; + cli: cli_handle_t; + arg_help: string option; + group: string option; + } + + let schema = + Schema.create "environment" + + (* Environment data *) + let env = + Data.create () + + (* Environment data from file *) + let env_from_file = + ref MapString.empty + + (* Lexer for var *) + let var_lxr = + Genlex.make_lexer [] + + let rec var_expand str = + let buff = + Buffer.create ((String.length str) * 2) + in + Buffer.add_substitute + buff + (fun var -> + try + (* TODO: this is a quick hack to allow calling Test.Command + * without defining executable name really. I.e. if there is + * an exec Executable toto, then $(toto) should be replace + * by its real name. It is however useful to have this function + * for other variable that depend on the host and should be + * written better than that. + *) + let st = + var_lxr (Stream.of_string var) + in + match Stream.npeek 3 st with + | [Genlex.Ident "utoh"; Genlex.Ident nm] -> + OASISHostPath.of_unix (var_get nm) + | [Genlex.Ident "utoh"; Genlex.String s] -> + OASISHostPath.of_unix s + | [Genlex.Ident "ocaml_escaped"; Genlex.Ident nm] -> + String.escaped (var_get nm) + | [Genlex.Ident "ocaml_escaped"; Genlex.String s] -> + String.escaped s + | [Genlex.Ident nm] -> + var_get nm + | _ -> + failwithf + (f_ "Unknown expression '%s' in variable expansion of %s.") + var + str + with + | Unknown_field (_, _) -> + failwithf + (f_ "No variable %s defined when trying to expand %S.") + var + str + | Stream.Error e -> + failwithf + (f_ "Syntax error when parsing '%s' when trying to \ + expand %S: %s") + var + str + e) + str; + Buffer.contents buff + + and var_get name = + let vl = + try + Schema.get schema env name + with Unknown_field _ as e -> + begin + try + MapString.find name !env_from_file + with Not_found -> + raise e + end + in + var_expand vl + + let var_choose ?printer ?name lst = + OASISExpr.choose + ?printer + ?name + var_get + lst + + let var_protect vl = + let buff = + Buffer.create (String.length vl) + in + String.iter + (function + | '$' -> Buffer.add_string buff "\\$" + | c -> Buffer.add_char buff c) + vl; + Buffer.contents buff + + let var_define + ?(hide=false) + ?(dump=true) + ?short_desc + ?(cli=CLINone) + ?arg_help + ?group + name (* TODO: type constraint on the fact that name must be a valid OCaml + id *) + dflt = + + let default = + [ + OFileLoad, (fun () -> MapString.find name !env_from_file); + ODefault, dflt; + OGetEnv, (fun () -> Sys.getenv name); + ] + in + + let extra = + { + hide = hide; + dump = dump; + cli = cli; + arg_help = arg_help; + group = group; + } + in + + (* Try to find a value that can be defined + *) + let var_get_low lst = + let errors, res = + List.fold_left + (fun (errors, res) (o, v) -> + if res = None then + begin + try + errors, Some (v ()) + with + | Not_found -> + errors, res + | Failure rsn -> + (rsn :: errors), res + | e -> + (Printexc.to_string e) :: errors, res + end + else + errors, res) + ([], None) + (List.sort + (fun (o1, _) (o2, _) -> + Pervasives.compare o2 o1) + lst) + in + match res, errors with + | Some v, _ -> + v + | None, [] -> + raise (Not_set (name, None)) + | None, lst -> + raise (Not_set (name, Some (String.concat (s_ ", ") lst))) + in + + let help = + match short_desc with + | Some fs -> Some fs + | None -> None + in + + let var_get_lst = + FieldRO.create + ~schema + ~name + ~parse:(fun ?(context=ODefault) s -> [context, fun () -> s]) + ~print:var_get_low + ~default + ~update:(fun ?context x old_x -> x @ old_x) + ?help + extra + in + + fun () -> + var_expand (var_get_low (var_get_lst env)) + + let var_redefine + ?hide + ?dump + ?short_desc + ?cli + ?arg_help + ?group + name + dflt = + if Schema.mem schema name then + begin + (* TODO: look suspsicious, we want to memorize dflt not dflt () *) + Schema.set schema env ~context:ODefault name (dflt ()); + fun () -> var_get name + end + else + begin + var_define + ?hide + ?dump + ?short_desc + ?cli + ?arg_help + ?group + name + dflt + end + + let var_ignore (e : unit -> string) = + () + + let print_hidden = + var_define + ~hide:true + ~dump:false + ~cli:CLIAuto + ~arg_help:"Print even non-printable variable. (debug)" + "print_hidden" + (fun () -> "false") + + let var_all () = + List.rev + (Schema.fold + (fun acc nm def _ -> + if not def.hide || bool_of_string (print_hidden ()) then + nm :: acc + else + acc) + [] + schema) + + let default_filename = + BaseEnvLight.default_filename + + let load ?allow_empty ?filename () = + env_from_file := BaseEnvLight.load ?allow_empty ?filename () + + let unload () = + env_from_file := MapString.empty; + Data.clear env + + let dump ?(filename=default_filename) () = + let chn = + open_out_bin filename + in + let output nm value = + Printf.fprintf chn "%s=%S\n" nm value + in + let mp_todo = + (* Dump data from schema *) + Schema.fold + (fun mp_todo nm def _ -> + if def.dump then + begin + try + let value = + Schema.get + schema + env + nm + in + output nm value + with Not_set _ -> + () + end; + MapString.remove nm mp_todo) + !env_from_file + schema + in + (* Dump data defined outside of schema *) + MapString.iter output mp_todo; + + (* End of the dump *) + close_out chn + + let print () = + let printable_vars = + Schema.fold + (fun acc nm def short_descr_opt -> + if not def.hide || bool_of_string (print_hidden ()) then + begin + try + let value = + Schema.get + schema + env + nm + in + let txt = + match short_descr_opt with + | Some s -> s () + | None -> nm + in + (txt, value) :: acc + with Not_set _ -> + acc + end + else + acc) + [] + schema + in + let max_length = + List.fold_left max 0 + (List.rev_map String.length + (List.rev_map fst printable_vars)) + in + let dot_pad str = + String.make ((max_length - (String.length str)) + 3) '.' + in + + Printf.printf "\nConfiguration: \n"; + List.iter + (fun (name,value) -> + Printf.printf "%s: %s %s\n" name (dot_pad name) value) + (List.rev printable_vars); + Printf.printf "\n%!" + + let args () = + let arg_concat = + OASISUtils.varname_concat ~hyphen:'-' + in + [ + "--override", + Arg.Tuple + ( + let rvr = ref "" + in + let rvl = ref "" + in + [ + Arg.Set_string rvr; + Arg.Set_string rvl; + Arg.Unit + (fun () -> + Schema.set + schema + env + ~context:OCommandLine + !rvr + !rvl) + ] + ), + "var+val Override any configuration variable."; + + ] + @ + List.flatten + (Schema.fold + (fun acc name def short_descr_opt -> + let var_set s = + Schema.set + schema + env + ~context:OCommandLine + name + s + in + + let arg_name = + OASISUtils.varname_of_string ~hyphen:'-' name + in + + let hlp = + match short_descr_opt with + | Some txt -> txt () + | None -> "" + in + + let arg_hlp = + match def.arg_help with + | Some s -> s + | None -> "str" + in + + let default_value = + try + Printf.sprintf + (f_ " [%s]") + (Schema.get + schema + env + name) + with Not_set _ -> + "" + in + + let args = + match def.cli with + | CLINone -> + [] + | CLIAuto -> + [ + arg_concat "--" arg_name, + Arg.String var_set, + Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value + ] + | CLIWith -> + [ + arg_concat "--with-" arg_name, + Arg.String var_set, + Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value + ] + | CLIEnable -> + let dflt = + if default_value = " [true]" then + s_ " [default: enabled]" + else + s_ " [default: disabled]" + in + [ + arg_concat "--enable-" arg_name, + Arg.Unit (fun () -> var_set "true"), + Printf.sprintf (f_ " %s%s") hlp dflt; + + arg_concat "--disable-" arg_name, + Arg.Unit (fun () -> var_set "false"), + Printf.sprintf (f_ " %s%s") hlp dflt + ] + | CLIUser lst -> + lst + in + args :: acc) + [] + schema) +end + +module BaseArgExt = struct +(* # 21 "src/base/BaseArgExt.ml" *) + + open OASISUtils + open OASISGettext + + let parse argv args = + (* Simulate command line for Arg *) + let current = + ref 0 + in + + try + Arg.parse_argv + ~current:current + (Array.concat [[|"none"|]; argv]) + (Arg.align args) + (failwithf (f_ "Don't know what to do with arguments: '%s'")) + (s_ "configure options:") + with + | Arg.Help txt -> + print_endline txt; + exit 0 + | Arg.Bad txt -> + prerr_endline txt; + exit 1 +end + +module BaseCheck = struct +(* # 21 "src/base/BaseCheck.ml" *) + + open BaseEnv + open BaseMessage + open OASISUtils + open OASISGettext + + let prog_best prg prg_lst = + var_redefine + prg + (fun () -> + let alternate = + List.fold_left + (fun res e -> + match res with + | Some _ -> + res + | None -> + try + Some (OASISFileUtil.which ~ctxt:!BaseContext.default e) + with Not_found -> + None) + None + prg_lst + in + match alternate with + | Some prg -> prg + | None -> raise Not_found) + + let prog prg = + prog_best prg [prg] + + let prog_opt prg = + prog_best prg [prg^".opt"; prg] + + let ocamlfind = + prog "ocamlfind" + + let version + var_prefix + cmp + fversion + () = + (* Really compare version provided *) + let var = + var_prefix^"_version_"^(OASISVersion.varname_of_comparator cmp) + in + var_redefine + ~hide:true + var + (fun () -> + let version_str = + match fversion () with + | "[Distributed with OCaml]" -> + begin + try + (var_get "ocaml_version") + with Not_found -> + warning + (f_ "Variable ocaml_version not defined, fallback \ + to default"); + Sys.ocaml_version + end + | res -> + res + in + let version = + OASISVersion.version_of_string version_str + in + if OASISVersion.comparator_apply version cmp then + version_str + else + failwithf + (f_ "Cannot satisfy version constraint on %s: %s (version: %s)") + var_prefix + (OASISVersion.string_of_comparator cmp) + version_str) + () + + let package_version pkg = + OASISExec.run_read_one_line ~ctxt:!BaseContext.default + (ocamlfind ()) + ["query"; "-format"; "%v"; pkg] + + let package ?version_comparator pkg () = + let var = + OASISUtils.varname_concat + "pkg_" + (OASISUtils.varname_of_string pkg) + in + let findlib_dir pkg = + let dir = + OASISExec.run_read_one_line ~ctxt:!BaseContext.default + (ocamlfind ()) + ["query"; "-format"; "%d"; pkg] + in + if Sys.file_exists dir && Sys.is_directory dir then + dir + else + failwithf + (f_ "When looking for findlib package %s, \ + directory %s return doesn't exist") + pkg dir + in + let vl = + var_redefine + var + (fun () -> findlib_dir pkg) + () + in + ( + match version_comparator with + | Some ver_cmp -> + ignore + (version + var + ver_cmp + (fun _ -> package_version pkg) + ()) + | None -> + () + ); + vl +end + +module BaseOCamlcConfig = struct +(* # 21 "src/base/BaseOCamlcConfig.ml" *) + + + open BaseEnv + open OASISUtils + open OASISGettext + + module SMap = Map.Make(String) + + let ocamlc = + BaseCheck.prog_opt "ocamlc" + + let ocamlc_config_map = + (* Map name to value for ocamlc -config output + (name ^": "^value) + *) + let rec split_field mp lst = + match lst with + | line :: tl -> + let mp = + try + let pos_semicolon = + String.index line ':' + in + if pos_semicolon > 1 then + ( + let name = + String.sub line 0 pos_semicolon + in + let linelen = + String.length line + in + let value = + if linelen > pos_semicolon + 2 then + String.sub + line + (pos_semicolon + 2) + (linelen - pos_semicolon - 2) + else + "" + in + SMap.add name value mp + ) + else + ( + mp + ) + with Not_found -> + ( + mp + ) + in + split_field mp tl + | [] -> + mp + in + + let cache = + lazy + (var_protect + (Marshal.to_string + (split_field + SMap.empty + (OASISExec.run_read_output + ~ctxt:!BaseContext.default + (ocamlc ()) ["-config"])) + [])) + in + var_redefine + "ocamlc_config_map" + ~hide:true + ~dump:false + (fun () -> + (* TODO: update if ocamlc change !!! *) + Lazy.force cache) + + let var_define nm = + (* Extract data from ocamlc -config *) + let avlbl_config_get () = + Marshal.from_string + (ocamlc_config_map ()) + 0 + in + let chop_version_suffix s = + try + String.sub s 0 (String.index s '+') + with _ -> + s + in + + let nm_config, value_config = + match nm with + | "ocaml_version" -> + "version", chop_version_suffix + | _ -> nm, (fun x -> x) + in + var_redefine + nm + (fun () -> + try + let map = + avlbl_config_get () + in + let value = + SMap.find nm_config map + in + value_config value + with Not_found -> + failwithf + (f_ "Cannot find field '%s' in '%s -config' output") + nm + (ocamlc ())) + +end + +module BaseStandardVar = struct +(* # 21 "src/base/BaseStandardVar.ml" *) + + + open OASISGettext + open OASISTypes + open OASISExpr + open BaseCheck + open BaseEnv + + let ocamlfind = BaseCheck.ocamlfind + let ocamlc = BaseOCamlcConfig.ocamlc + let ocamlopt = prog_opt "ocamlopt" + let ocamlbuild = prog "ocamlbuild" + + + (**/**) + let rpkg = + ref None + + let pkg_get () = + match !rpkg with + | Some pkg -> pkg + | None -> failwith (s_ "OASIS Package is not set") + + let var_cond = ref [] + + let var_define_cond ~since_version f dflt = + let holder = ref (fun () -> dflt) in + let since_version = + OASISVersion.VGreaterEqual (OASISVersion.version_of_string since_version) + in + var_cond := + (fun ver -> + if OASISVersion.comparator_apply ver since_version then + holder := f ()) :: !var_cond; + fun () -> !holder () + + (**/**) + + let pkg_name = + var_define + ~short_desc:(fun () -> s_ "Package name") + "pkg_name" + (fun () -> (pkg_get ()).name) + + let pkg_version = + var_define + ~short_desc:(fun () -> s_ "Package version") + "pkg_version" + (fun () -> + (OASISVersion.string_of_version (pkg_get ()).version)) + + let c = BaseOCamlcConfig.var_define + + let os_type = c "os_type" + let system = c "system" + let architecture = c "architecture" + let ccomp_type = c "ccomp_type" + let ocaml_version = c "ocaml_version" + + (* TODO: Check standard variable presence at runtime *) + + let standard_library_default = c "standard_library_default" + let standard_library = c "standard_library" + let standard_runtime = c "standard_runtime" + let bytecomp_c_compiler = c "bytecomp_c_compiler" + let native_c_compiler = c "native_c_compiler" + let model = c "model" + let ext_obj = c "ext_obj" + let ext_asm = c "ext_asm" + let ext_lib = c "ext_lib" + let ext_dll = c "ext_dll" + let default_executable_name = c "default_executable_name" + let systhread_supported = c "systhread_supported" + + let flexlink = + BaseCheck.prog "flexlink" + + let flexdll_version = + var_define + ~short_desc:(fun () -> "FlexDLL version (Win32)") + "flexdll_version" + (fun () -> + let lst = + OASISExec.run_read_output ~ctxt:!BaseContext.default + (flexlink ()) ["-help"] + in + match lst with + | line :: _ -> + Scanf.sscanf line "FlexDLL version %s" (fun ver -> ver) + | [] -> + raise Not_found) + + (**/**) + let p name hlp dflt = + var_define + ~short_desc:hlp + ~cli:CLIAuto + ~arg_help:"dir" + name + dflt + + let (/) a b = + if os_type () = Sys.os_type then + Filename.concat a b + else if os_type () = "Unix" then + OASISUnixPath.concat a b + else + OASISUtils.failwithf (f_ "Cannot handle os_type %s filename concat") + (os_type ()) + (**/**) + + let prefix = + p "prefix" + (fun () -> s_ "Install architecture-independent files dir") + (fun () -> + match os_type () with + | "Win32" -> + let program_files = + Sys.getenv "PROGRAMFILES" + in + program_files/(pkg_name ()) + | _ -> + "/usr/local") + + let exec_prefix = + p "exec_prefix" + (fun () -> s_ "Install architecture-dependent files in dir") + (fun () -> "$prefix") + + let bindir = + p "bindir" + (fun () -> s_ "User executables") + (fun () -> "$exec_prefix"/"bin") + + let sbindir = + p "sbindir" + (fun () -> s_ "System admin executables") + (fun () -> "$exec_prefix"/"sbin") + + let libexecdir = + p "libexecdir" + (fun () -> s_ "Program executables") + (fun () -> "$exec_prefix"/"libexec") + + let sysconfdir = + p "sysconfdir" + (fun () -> s_ "Read-only single-machine data") + (fun () -> "$prefix"/"etc") + + let sharedstatedir = + p "sharedstatedir" + (fun () -> s_ "Modifiable architecture-independent data") + (fun () -> "$prefix"/"com") + + let localstatedir = + p "localstatedir" + (fun () -> s_ "Modifiable single-machine data") + (fun () -> "$prefix"/"var") + + let libdir = + p "libdir" + (fun () -> s_ "Object code libraries") + (fun () -> "$exec_prefix"/"lib") + + let datarootdir = + p "datarootdir" + (fun () -> s_ "Read-only arch-independent data root") + (fun () -> "$prefix"/"share") + + let datadir = + p "datadir" + (fun () -> s_ "Read-only architecture-independent data") + (fun () -> "$datarootdir") + + let infodir = + p "infodir" + (fun () -> s_ "Info documentation") + (fun () -> "$datarootdir"/"info") + + let localedir = + p "localedir" + (fun () -> s_ "Locale-dependent data") + (fun () -> "$datarootdir"/"locale") + + let mandir = + p "mandir" + (fun () -> s_ "Man documentation") + (fun () -> "$datarootdir"/"man") + + let docdir = + p "docdir" + (fun () -> s_ "Documentation root") + (fun () -> "$datarootdir"/"doc"/"$pkg_name") + + let htmldir = + p "htmldir" + (fun () -> s_ "HTML documentation") + (fun () -> "$docdir") + + let dvidir = + p "dvidir" + (fun () -> s_ "DVI documentation") + (fun () -> "$docdir") + + let pdfdir = + p "pdfdir" + (fun () -> s_ "PDF documentation") + (fun () -> "$docdir") + + let psdir = + p "psdir" + (fun () -> s_ "PS documentation") + (fun () -> "$docdir") + + let destdir = + p "destdir" + (fun () -> s_ "Prepend a path when installing package") + (fun () -> + raise + (PropList.Not_set + ("destdir", + Some (s_ "undefined by construct")))) + + let findlib_version = + var_define + "findlib_version" + (fun () -> + BaseCheck.package_version "findlib") + + let is_native = + var_define + "is_native" + (fun () -> + try + let _s : string = + ocamlopt () + in + "true" + with PropList.Not_set _ -> + let _s : string = + ocamlc () + in + "false") + + let ext_program = + var_define + "suffix_program" + (fun () -> + match os_type () with + | "Win32" -> ".exe" + | _ -> "") + + let rm = + var_define + ~short_desc:(fun () -> s_ "Remove a file.") + "rm" + (fun () -> + match os_type () with + | "Win32" -> "del" + | _ -> "rm -f") + + let rmdir = + var_define + ~short_desc:(fun () -> s_ "Remove a directory.") + "rmdir" + (fun () -> + match os_type () with + | "Win32" -> "rd" + | _ -> "rm -rf") + + let debug = + var_define + ~short_desc:(fun () -> s_ "Turn ocaml debug flag on") + ~cli:CLIEnable + "debug" + (fun () -> "true") + + let profile = + var_define + ~short_desc:(fun () -> s_ "Turn ocaml profile flag on") + ~cli:CLIEnable + "profile" + (fun () -> "false") + + let tests = + var_define_cond ~since_version:"0.3" + (fun () -> + var_define + ~short_desc:(fun () -> + s_ "Compile tests executable and library and run them") + ~cli:CLIEnable + "tests" + (fun () -> "false")) + "true" + + let docs = + var_define_cond ~since_version:"0.3" + (fun () -> + var_define + ~short_desc:(fun () -> s_ "Create documentations") + ~cli:CLIEnable + "docs" + (fun () -> "true")) + "true" + + let native_dynlink = + var_define + ~short_desc:(fun () -> s_ "Compiler support generation of .cmxs.") + ~cli:CLINone + "native_dynlink" + (fun () -> + let res = + let ocaml_lt_312 () = + OASISVersion.comparator_apply + (OASISVersion.version_of_string (ocaml_version ())) + (OASISVersion.VLesser + (OASISVersion.version_of_string "3.12.0")) + in + let flexdll_lt_030 () = + OASISVersion.comparator_apply + (OASISVersion.version_of_string (flexdll_version ())) + (OASISVersion.VLesser + (OASISVersion.version_of_string "0.30")) + in + let has_native_dynlink = + let ocamlfind = ocamlfind () in + try + let fn = + OASISExec.run_read_one_line + ~ctxt:!BaseContext.default + ocamlfind + ["query"; "-predicates"; "native"; "dynlink"; + "-format"; "%d/%a"] + in + Sys.file_exists fn + with _ -> + false + in + if not has_native_dynlink then + false + else if ocaml_lt_312 () then + false + else if (os_type () = "Win32" || os_type () = "Cygwin") + && flexdll_lt_030 () then + begin + BaseMessage.warning + (f_ ".cmxs generation disabled because FlexDLL needs to be \ + at least 0.30. Please upgrade FlexDLL from %s to 0.30.") + (flexdll_version ()); + false + end + else + true + in + string_of_bool res) + + let init pkg = + rpkg := Some pkg; + List.iter (fun f -> f pkg.oasis_version) !var_cond + +end + +module BaseFileAB = struct +(* # 21 "src/base/BaseFileAB.ml" *) + + open BaseEnv + open OASISGettext + open BaseMessage + + let to_filename fn = + let fn = + OASISHostPath.of_unix fn + in + if not (Filename.check_suffix fn ".ab") then + warning + (f_ "File '%s' doesn't have '.ab' extension") + fn; + Filename.chop_extension fn + + let replace fn_lst = + let buff = + Buffer.create 13 + in + List.iter + (fun fn -> + let fn = + OASISHostPath.of_unix fn + in + let chn_in = + open_in fn + in + let chn_out = + open_out (to_filename fn) + in + ( + try + while true do + Buffer.add_string buff (var_expand (input_line chn_in)); + Buffer.add_char buff '\n' + done + with End_of_file -> + () + ); + Buffer.output_buffer chn_out buff; + Buffer.clear buff; + close_in chn_in; + close_out chn_out) + fn_lst +end + +module BaseLog = struct +(* # 21 "src/base/BaseLog.ml" *) + + open OASISUtils + + let default_filename = + Filename.concat + (Filename.dirname BaseEnv.default_filename) + "setup.log" + + module SetTupleString = + Set.Make + (struct + type t = string * string + let compare (s11, s12) (s21, s22) = + match String.compare s11 s21 with + | 0 -> String.compare s12 s22 + | n -> n + end) + + let load () = + if Sys.file_exists default_filename then + begin + let chn = + open_in default_filename + in + let scbuf = + Scanf.Scanning.from_file default_filename + in + let rec read_aux (st, lst) = + if not (Scanf.Scanning.end_of_input scbuf) then + begin + let acc = + try + Scanf.bscanf scbuf "%S %S\n" + (fun e d -> + let t = + e, d + in + if SetTupleString.mem t st then + st, lst + else + SetTupleString.add t st, + t :: lst) + with Scanf.Scan_failure _ -> + failwith + (Scanf.bscanf scbuf + "%l" + (fun line -> + Printf.sprintf + "Malformed log file '%s' at line %d" + default_filename + line)) + in + read_aux acc + end + else + begin + close_in chn; + List.rev lst + end + in + read_aux (SetTupleString.empty, []) + end + else + begin + [] + end + + let register event data = + let chn_out = + open_out_gen [Open_append; Open_creat; Open_text] 0o644 default_filename + in + Printf.fprintf chn_out "%S %S\n" event data; + close_out chn_out + + let unregister event data = + if Sys.file_exists default_filename then + begin + let lst = + load () + in + let chn_out = + open_out default_filename + in + let write_something = + ref false + in + List.iter + (fun (e, d) -> + if e <> event || d <> data then + begin + write_something := true; + Printf.fprintf chn_out "%S %S\n" e d + end) + lst; + close_out chn_out; + if not !write_something then + Sys.remove default_filename + end + + let filter events = + let st_events = + List.fold_left + (fun st e -> + SetString.add e st) + SetString.empty + events + in + List.filter + (fun (e, _) -> SetString.mem e st_events) + (load ()) + + let exists event data = + List.exists + (fun v -> (event, data) = v) + (load ()) +end + +module BaseBuilt = struct +(* # 21 "src/base/BaseBuilt.ml" *) + + open OASISTypes + open OASISGettext + open BaseStandardVar + open BaseMessage + + type t = + | BExec (* Executable *) + | BExecLib (* Library coming with executable *) + | BLib (* Library *) + | BObj (* Library *) + | BDoc (* Document *) + + let to_log_event_file t nm = + "built_"^ + (match t with + | BExec -> "exec" + | BExecLib -> "exec_lib" + | BLib -> "lib" + | BObj -> "obj" + | BDoc -> "doc")^ + "_"^nm + + let to_log_event_done t nm = + "is_"^(to_log_event_file t nm) + + let register t nm lst = + BaseLog.register + (to_log_event_done t nm) + "true"; + List.iter + (fun alt -> + let registered = + List.fold_left + (fun registered fn -> + if OASISFileUtil.file_exists_case fn then + begin + BaseLog.register + (to_log_event_file t nm) + (if Filename.is_relative fn then + Filename.concat (Sys.getcwd ()) fn + else + fn); + true + end + else + registered) + false + alt + in + if not registered then + warning + (f_ "Cannot find an existing alternative files among: %s") + (String.concat (s_ ", ") alt)) + lst + + let unregister t nm = + List.iter + (fun (e, d) -> + BaseLog.unregister e d) + (BaseLog.filter + [to_log_event_file t nm; + to_log_event_done t nm]) + + let fold t nm f acc = + List.fold_left + (fun acc (_, fn) -> + if OASISFileUtil.file_exists_case fn then + begin + f acc fn + end + else + begin + warning + (f_ "File '%s' has been marked as built \ + for %s but doesn't exist") + fn + (Printf.sprintf + (match t with + | BExec | BExecLib -> + (f_ "executable %s") + | BLib -> + (f_ "library %s") + | BObj -> + (f_ "object %s") + | BDoc -> + (f_ "documentation %s")) + nm); + acc + end) + acc + (BaseLog.filter + [to_log_event_file t nm]) + + let is_built t nm = + List.fold_left + (fun is_built (_, d) -> + (try + bool_of_string d + with _ -> + false)) + false + (BaseLog.filter + [to_log_event_done t nm]) + + let of_executable ffn (cs, bs, exec) = + let unix_exec_is, unix_dll_opt = + OASISExecutable.unix_exec_is + (cs, bs, exec) + (fun () -> + bool_of_string + (is_native ())) + ext_dll + ext_program + in + let evs = + (BExec, cs.cs_name, [[ffn unix_exec_is]]) + :: + (match unix_dll_opt with + | Some fn -> + [BExecLib, cs.cs_name, [[ffn fn]]] + | None -> + []) + in + evs, + unix_exec_is, + unix_dll_opt + + let of_library ffn (cs, bs, lib) = + let unix_lst = + OASISLibrary.generated_unix_files + ~ctxt:!BaseContext.default + ~source_file_exists:(fun fn -> + OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) + ~is_native:(bool_of_string (is_native ())) + ~has_native_dynlink:(bool_of_string (native_dynlink ())) + ~ext_lib:(ext_lib ()) + ~ext_dll:(ext_dll ()) + (cs, bs, lib) + in + let evs = + [BLib, + cs.cs_name, + List.map (List.map ffn) unix_lst] + in + evs, unix_lst + + + let of_object ffn (cs, bs, obj) = + let unix_lst = + OASISObject.generated_unix_files + ~ctxt:!BaseContext.default + ~source_file_exists:(fun fn -> + OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) + ~is_native:(bool_of_string (is_native ())) + (cs, bs, obj) + in + let evs = + [BObj, + cs.cs_name, + List.map (List.map ffn) unix_lst] + in + evs, unix_lst + +end + +module BaseCustom = struct +(* # 21 "src/base/BaseCustom.ml" *) + + open BaseEnv + open BaseMessage + open OASISTypes + open OASISGettext + + let run cmd args extra_args = + OASISExec.run ~ctxt:!BaseContext.default ~quote:false + (var_expand cmd) + (List.map + var_expand + (args @ (Array.to_list extra_args))) + + let hook ?(failsafe=false) cstm f e = + let optional_command lst = + let printer = + function + | Some (cmd, args) -> String.concat " " (cmd :: args) + | None -> s_ "No command" + in + match + var_choose + ~name:(s_ "Pre/Post Command") + ~printer + lst with + | Some (cmd, args) -> + begin + try + run cmd args [||] + with e when failsafe -> + warning + (f_ "Command '%s' fail with error: %s") + (String.concat " " (cmd :: args)) + (match e with + | Failure msg -> msg + | e -> Printexc.to_string e) + end + | None -> + () + in + let res = + optional_command cstm.pre_command; + f e + in + optional_command cstm.post_command; + res +end + +module BaseDynVar = struct +(* # 21 "src/base/BaseDynVar.ml" *) + + + open OASISTypes + open OASISGettext + open BaseEnv + open BaseBuilt + + let init pkg = + (* TODO: disambiguate exec vs other variable by adding exec_VARNAME. *) + (* TODO: provide compile option for library libary_byte_args_VARNAME... *) + List.iter + (function + | Executable (cs, bs, exec) -> + if var_choose bs.bs_build then + var_ignore + (var_redefine + (* We don't save this variable *) + ~dump:false + ~short_desc:(fun () -> + Printf.sprintf + (f_ "Filename of executable '%s'") + cs.cs_name) + (OASISUtils.varname_of_string cs.cs_name) + (fun () -> + let fn_opt = + fold + BExec cs.cs_name + (fun _ fn -> Some fn) + None + in + match fn_opt with + | Some fn -> fn + | None -> + raise + (PropList.Not_set + (cs.cs_name, + Some (Printf.sprintf + (f_ "Executable '%s' not yet built.") + cs.cs_name))))) + + | Library _ | Object _ | Flag _ | Test _ | SrcRepo _ | Doc _ -> + ()) + pkg.sections +end + +module BaseTest = struct +(* # 21 "src/base/BaseTest.ml" *) + + open BaseEnv + open BaseMessage + open OASISTypes + open OASISExpr + open OASISGettext + + let test lst pkg extra_args = + + let one_test (failure, n) (test_plugin, cs, test) = + if var_choose + ~name:(Printf.sprintf + (f_ "test %s run") + cs.cs_name) + ~printer:string_of_bool + test.test_run then + begin + let () = + info (f_ "Running test '%s'") cs.cs_name + in + let back_cwd = + match test.test_working_directory with + | Some dir -> + let cwd = + Sys.getcwd () + in + let chdir d = + info (f_ "Changing directory to '%s'") d; + Sys.chdir d + in + chdir dir; + fun () -> chdir cwd + + | None -> + fun () -> () + in + try + let failure_percent = + BaseCustom.hook + test.test_custom + (test_plugin pkg (cs, test)) + extra_args + in + back_cwd (); + (failure_percent +. failure, n + 1) + with e -> + begin + back_cwd (); + raise e + end + end + else + begin + info (f_ "Skipping test '%s'") cs.cs_name; + (failure, n) + end + in + let (failed, n) = + List.fold_left + one_test + (0.0, 0) + lst + in + let failure_percent = + if n = 0 then + 0.0 + else + failed /. (float_of_int n) + in + let msg = + Printf.sprintf + (f_ "Tests had a %.2f%% failure rate") + (100. *. failure_percent) + in + if failure_percent > 0.0 then + failwith msg + else + info "%s" msg; + + (* Possible explanation why the tests where not run. *) + if OASISVersion.version_0_3_or_after pkg.oasis_version && + not (bool_of_string (BaseStandardVar.tests ())) && + lst <> [] then + BaseMessage.warning + "Tests are turned off, consider enabling with \ + 'ocaml setup.ml -configure --enable-tests'" +end + +module BaseDoc = struct +(* # 21 "src/base/BaseDoc.ml" *) + + open BaseEnv + open BaseMessage + open OASISTypes + open OASISGettext + + let doc lst pkg extra_args = + + let one_doc (doc_plugin, cs, doc) = + if var_choose + ~name:(Printf.sprintf + (f_ "documentation %s build") + cs.cs_name) + ~printer:string_of_bool + doc.doc_build then + begin + info (f_ "Building documentation '%s'") cs.cs_name; + BaseCustom.hook + doc.doc_custom + (doc_plugin pkg (cs, doc)) + extra_args + end + in + List.iter one_doc lst; + + if OASISVersion.version_0_3_or_after pkg.oasis_version && + not (bool_of_string (BaseStandardVar.docs ())) && + lst <> [] then + BaseMessage.warning + "Docs are turned off, consider enabling with \ + 'ocaml setup.ml -configure --enable-docs'" +end + +module BaseSetup = struct +(* # 21 "src/base/BaseSetup.ml" *) + + open BaseEnv + open BaseMessage + open OASISTypes + open OASISSection + open OASISGettext + open OASISUtils + + type std_args_fun = + package -> string array -> unit + + type ('a, 'b) section_args_fun = + name * (package -> (common_section * 'a) -> string array -> 'b) + + type t = + { + configure: std_args_fun; + build: std_args_fun; + doc: ((doc, unit) section_args_fun) list; + test: ((test, float) section_args_fun) list; + install: std_args_fun; + uninstall: std_args_fun; + clean: std_args_fun list; + clean_doc: (doc, unit) section_args_fun list; + clean_test: (test, unit) section_args_fun list; + distclean: std_args_fun list; + distclean_doc: (doc, unit) section_args_fun list; + distclean_test: (test, unit) section_args_fun list; + package: package; + oasis_fn: string option; + oasis_version: string; + oasis_digest: Digest.t option; + oasis_exec: string option; + oasis_setup_args: string list; + setup_update: bool; + } + + (* Associate a plugin function with data from package *) + let join_plugin_sections filter_map lst = + List.rev + (List.fold_left + (fun acc sct -> + match filter_map sct with + | Some e -> + e :: acc + | None -> + acc) + [] + lst) + + (* Search for plugin data associated with a section name *) + let lookup_plugin_section plugin action nm lst = + try + List.assoc nm lst + with Not_found -> + failwithf + (f_ "Cannot find plugin %s matching section %s for %s action") + plugin + nm + action + + let configure t args = + (* Run configure *) + BaseCustom.hook + t.package.conf_custom + (fun () -> + (* Reload if preconf has changed it *) + begin + try + unload (); + load (); + with _ -> + () + end; + + (* Run plugin's configure *) + t.configure t.package args; + + (* Dump to allow postconf to change it *) + dump ()) + (); + + (* Reload environment *) + unload (); + load (); + + (* Save environment *) + print (); + + (* Replace data in file *) + BaseFileAB.replace t.package.files_ab + + let build t args = + BaseCustom.hook + t.package.build_custom + (t.build t.package) + args + + let doc t args = + BaseDoc.doc + (join_plugin_sections + (function + | Doc (cs, e) -> + Some + (lookup_plugin_section + "documentation" + (s_ "build") + cs.cs_name + t.doc, + cs, + e) + | _ -> + None) + t.package.sections) + t.package + args + + let test t args = + BaseTest.test + (join_plugin_sections + (function + | Test (cs, e) -> + Some + (lookup_plugin_section + "test" + (s_ "run") + cs.cs_name + t.test, + cs, + e) + | _ -> + None) + t.package.sections) + t.package + args + + let all t args = + let rno_doc = + ref false + in + let rno_test = + ref false + in + Arg.parse_argv + ~current:(ref 0) + (Array.of_list + ((Sys.executable_name^" all") :: + (Array.to_list args))) + [ + "-no-doc", + Arg.Set rno_doc, + s_ "Don't run doc target"; + + "-no-test", + Arg.Set rno_test, + s_ "Don't run test target"; + ] + (failwithf (f_ "Don't know what to do with '%s'")) + ""; + + info "Running configure step"; + configure t [||]; + + info "Running build step"; + build t [||]; + + (* Load setup.log dynamic variables *) + BaseDynVar.init t.package; + + if not !rno_doc then + begin + info "Running doc step"; + doc t [||]; + end + else + begin + info "Skipping doc step" + end; + + if not !rno_test then + begin + info "Running test step"; + test t [||] + end + else + begin + info "Skipping test step" + end + + let install t args = + BaseCustom.hook + t.package.install_custom + (t.install t.package) + args + + let uninstall t args = + BaseCustom.hook + t.package.uninstall_custom + (t.uninstall t.package) + args + + let reinstall t args = + uninstall t args; + install t args + + let clean, distclean = + let failsafe f a = + try + f a + with e -> + warning + (f_ "Action fail with error: %s") + (match e with + | Failure msg -> msg + | e -> Printexc.to_string e) + in + + let generic_clean t cstm mains docs tests args = + BaseCustom.hook + ~failsafe:true + cstm + (fun () -> + (* Clean section *) + List.iter + (function + | Test (cs, test) -> + let f = + try + List.assoc cs.cs_name tests + with Not_found -> + fun _ _ _ -> () + in + failsafe + (f t.package (cs, test)) + args + | Doc (cs, doc) -> + let f = + try + List.assoc cs.cs_name docs + with Not_found -> + fun _ _ _ -> () + in + failsafe + (f t.package (cs, doc)) + args + | Library _ + | Object _ + | Executable _ + | Flag _ + | SrcRepo _ -> + ()) + t.package.sections; + (* Clean whole package *) + List.iter + (fun f -> + failsafe + (f t.package) + args) + mains) + () + in + + let clean t args = + generic_clean + t + t.package.clean_custom + t.clean + t.clean_doc + t.clean_test + args + in + + let distclean t args = + (* Call clean *) + clean t args; + + (* Call distclean code *) + generic_clean + t + t.package.distclean_custom + t.distclean + t.distclean_doc + t.distclean_test + args; + + (* Remove generated file *) + List.iter + (fun fn -> + if Sys.file_exists fn then + begin + info (f_ "Remove '%s'") fn; + Sys.remove fn + end) + (BaseEnv.default_filename + :: + BaseLog.default_filename + :: + (List.rev_map BaseFileAB.to_filename t.package.files_ab)) + in + + clean, distclean + + let version t _ = + print_endline t.oasis_version + + let update_setup_ml, no_update_setup_ml_cli = + let b = ref true in + b, + ("-no-update-setup-ml", + Arg.Clear b, + s_ " Don't try to update setup.ml, even if _oasis has changed.") + + let update_setup_ml t = + let oasis_fn = + match t.oasis_fn with + | Some fn -> fn + | None -> "_oasis" + in + let oasis_exec = + match t.oasis_exec with + | Some fn -> fn + | None -> "oasis" + in + let ocaml = + Sys.executable_name + in + let setup_ml, args = + match Array.to_list Sys.argv with + | setup_ml :: args -> + setup_ml, args + | [] -> + failwith + (s_ "Expecting non-empty command line arguments.") + in + let ocaml, setup_ml = + if Sys.executable_name = Sys.argv.(0) then + (* We are not running in standard mode, probably the script + * is precompiled. + *) + "ocaml", "setup.ml" + else + ocaml, setup_ml + in + let no_update_setup_ml_cli, _, _ = no_update_setup_ml_cli in + let do_update () = + let oasis_exec_version = + OASISExec.run_read_one_line + ~ctxt:!BaseContext.default + ~f_exit_code: + (function + | 0 -> + () + | 1 -> + failwithf + (f_ "Executable '%s' is probably an old version \ + of oasis (< 0.3.0), please update to version \ + v%s.") + oasis_exec t.oasis_version + | 127 -> + failwithf + (f_ "Cannot find executable '%s', please install \ + oasis v%s.") + oasis_exec t.oasis_version + | n -> + failwithf + (f_ "Command '%s version' exited with code %d.") + oasis_exec n) + oasis_exec ["version"] + in + if OASISVersion.comparator_apply + (OASISVersion.version_of_string oasis_exec_version) + (OASISVersion.VGreaterEqual + (OASISVersion.version_of_string t.oasis_version)) then + begin + (* We have a version >= for the executable oasis, proceed with + * update. + *) + (* TODO: delegate this check to 'oasis setup'. *) + if Sys.os_type = "Win32" then + failwithf + (f_ "It is not possible to update the running script \ + setup.ml on Windows. Please update setup.ml by \ + running '%s'.") + (String.concat " " (oasis_exec :: "setup" :: t.oasis_setup_args)) + else + begin + OASISExec.run + ~ctxt:!BaseContext.default + ~f_exit_code: + (function + | 0 -> + () + | n -> + failwithf + (f_ "Unable to update setup.ml using '%s', \ + please fix the problem and retry.") + oasis_exec) + oasis_exec ("setup" :: t.oasis_setup_args); + OASISExec.run ~ctxt:!BaseContext.default ocaml (setup_ml :: args) + end + end + else + failwithf + (f_ "The version of '%s' (v%s) doesn't match the version of \ + oasis used to generate the %s file. Please install at \ + least oasis v%s.") + oasis_exec oasis_exec_version setup_ml t.oasis_version + in + + if !update_setup_ml then + begin + try + match t.oasis_digest with + | Some dgst -> + if Sys.file_exists oasis_fn && dgst <> Digest.file "_oasis" then + begin + do_update (); + true + end + else + false + | None -> + false + with e -> + error + (f_ "Error when updating setup.ml. If you want to avoid this error, \ + you can bypass the update of %s by running '%s %s %s %s'") + setup_ml ocaml setup_ml no_update_setup_ml_cli + (String.concat " " args); + raise e + end + else + false + + let setup t = + let catch_exn = + ref true + in + try + let act_ref = + ref (fun _ -> + failwithf + (f_ "No action defined, run '%s %s -help'") + Sys.executable_name + Sys.argv.(0)) + + in + let extra_args_ref = + ref [] + in + let allow_empty_env_ref = + ref false + in + let arg_handle ?(allow_empty_env=false) act = + Arg.Tuple + [ + Arg.Rest (fun str -> extra_args_ref := str :: !extra_args_ref); + + Arg.Unit + (fun () -> + allow_empty_env_ref := allow_empty_env; + act_ref := act); + ] + in + + Arg.parse + (Arg.align + ([ + "-configure", + arg_handle ~allow_empty_env:true configure, + s_ "[options*] Configure the whole build process."; + + "-build", + arg_handle build, + s_ "[options*] Build executables and libraries."; + + "-doc", + arg_handle doc, + s_ "[options*] Build documents."; + + "-test", + arg_handle test, + s_ "[options*] Run tests."; + + "-all", + arg_handle ~allow_empty_env:true all, + s_ "[options*] Run configure, build, doc and test targets."; + + "-install", + arg_handle install, + s_ "[options*] Install libraries, data, executables \ + and documents."; + + "-uninstall", + arg_handle uninstall, + s_ "[options*] Uninstall libraries, data, executables \ + and documents."; + + "-reinstall", + arg_handle reinstall, + s_ "[options*] Uninstall and install libraries, data, \ + executables and documents."; + + "-clean", + arg_handle ~allow_empty_env:true clean, + s_ "[options*] Clean files generated by a build."; + + "-distclean", + arg_handle ~allow_empty_env:true distclean, + s_ "[options*] Clean files generated by a build and configure."; + + "-version", + arg_handle ~allow_empty_env:true version, + s_ " Display version of OASIS used to generate this setup.ml."; + + "-no-catch-exn", + Arg.Clear catch_exn, + s_ " Don't catch exception, useful for debugging."; + ] + @ + (if t.setup_update then + [no_update_setup_ml_cli] + else + []) + @ (BaseContext.args ()))) + (failwithf (f_ "Don't know what to do with '%s'")) + (s_ "Setup and run build process current package\n"); + + (* Build initial environment *) + load ~allow_empty:!allow_empty_env_ref (); + + (** Initialize flags *) + List.iter + (function + | Flag (cs, {flag_description = hlp; + flag_default = choices}) -> + begin + let apply ?short_desc () = + var_ignore + (var_define + ~cli:CLIEnable + ?short_desc + (OASISUtils.varname_of_string cs.cs_name) + (fun () -> + string_of_bool + (var_choose + ~name:(Printf.sprintf + (f_ "default value of flag %s") + cs.cs_name) + ~printer:string_of_bool + choices))) + in + match hlp with + | Some hlp -> + apply ~short_desc:(fun () -> hlp) () + | None -> + apply () + end + | _ -> + ()) + t.package.sections; + + BaseStandardVar.init t.package; + + BaseDynVar.init t.package; + + if t.setup_update && update_setup_ml t then + () + else + !act_ref t (Array.of_list (List.rev !extra_args_ref)) + + with e when !catch_exn -> + error "%s" (Printexc.to_string e); + exit 1 + +end + + +# 4617 "setup.ml" +module InternalConfigurePlugin = struct +(* # 21 "src/plugins/internal/InternalConfigurePlugin.ml" *) + + (** Configure using internal scheme + @author Sylvain Le Gall + *) + + open BaseEnv + open OASISTypes + open OASISUtils + open OASISGettext + open BaseMessage + + (** Configure build using provided series of check to be done + * and then output corresponding file. + *) + let configure pkg argv = + let var_ignore_eval var = + let _s : string = + var () + in + () + in + + let errors = + ref SetString.empty + in + + let buff = + Buffer.create 13 + in + + let add_errors fmt = + Printf.kbprintf + (fun b -> + errors := SetString.add (Buffer.contents b) !errors; + Buffer.clear b) + buff + fmt + in + + let warn_exception e = + warning "%s" (Printexc.to_string e) + in + + (* Check tools *) + let check_tools lst = + List.iter + (function + | ExternalTool tool -> + begin + try + var_ignore_eval (BaseCheck.prog tool) + with e -> + warn_exception e; + add_errors (f_ "Cannot find external tool '%s'") tool + end + | InternalExecutable nm1 -> + (* Check that matching tool is built *) + List.iter + (function + | Executable ({cs_name = nm2}, + {bs_build = build}, + _) when nm1 = nm2 -> + if not (var_choose build) then + add_errors + (f_ "Cannot find buildable internal executable \ + '%s' when checking build depends") + nm1 + | _ -> + ()) + pkg.sections) + lst + in + + let build_checks sct bs = + if var_choose bs.bs_build then + begin + if bs.bs_compiled_object = Native then + begin + try + var_ignore_eval BaseStandardVar.ocamlopt + with e -> + warn_exception e; + add_errors + (f_ "Section %s requires native compilation") + (OASISSection.string_of_section sct) + end; + + (* Check tools *) + check_tools bs.bs_build_tools; + + (* Check depends *) + List.iter + (function + | FindlibPackage (findlib_pkg, version_comparator) -> + begin + try + var_ignore_eval + (BaseCheck.package ?version_comparator findlib_pkg) + with e -> + warn_exception e; + match version_comparator with + | None -> + add_errors + (f_ "Cannot find findlib package %s") + findlib_pkg + | Some ver_cmp -> + add_errors + (f_ "Cannot find findlib package %s (%s)") + findlib_pkg + (OASISVersion.string_of_comparator ver_cmp) + end + | InternalLibrary nm1 -> + (* Check that matching library is built *) + List.iter + (function + | Library ({cs_name = nm2}, + {bs_build = build}, + _) when nm1 = nm2 -> + if not (var_choose build) then + add_errors + (f_ "Cannot find buildable internal library \ + '%s' when checking build depends") + nm1 + | _ -> + ()) + pkg.sections) + bs.bs_build_depends + end + in + + (* Parse command line *) + BaseArgExt.parse argv (BaseEnv.args ()); + + (* OCaml version *) + begin + match pkg.ocaml_version with + | Some ver_cmp -> + begin + try + var_ignore_eval + (BaseCheck.version + "ocaml" + ver_cmp + BaseStandardVar.ocaml_version) + with e -> + warn_exception e; + add_errors + (f_ "OCaml version %s doesn't match version constraint %s") + (BaseStandardVar.ocaml_version ()) + (OASISVersion.string_of_comparator ver_cmp) + end + | None -> + () + end; + + (* Findlib version *) + begin + match pkg.findlib_version with + | Some ver_cmp -> + begin + try + var_ignore_eval + (BaseCheck.version + "findlib" + ver_cmp + BaseStandardVar.findlib_version) + with e -> + warn_exception e; + add_errors + (f_ "Findlib version %s doesn't match version constraint %s") + (BaseStandardVar.findlib_version ()) + (OASISVersion.string_of_comparator ver_cmp) + end + | None -> + () + end; + (* Make sure the findlib version is fine for the OCaml compiler. *) + begin + let ocaml_ge4 = + OASISVersion.version_compare + (OASISVersion.version_of_string (BaseStandardVar.ocaml_version())) + (OASISVersion.version_of_string "4.0.0") >= 0 in + if ocaml_ge4 then + let findlib_lt132 = + OASISVersion.version_compare + (OASISVersion.version_of_string (BaseStandardVar.findlib_version())) + (OASISVersion.version_of_string "1.3.2") < 0 in + if findlib_lt132 then + add_errors "OCaml >= 4.0.0 requires Findlib version >= 1.3.2" + end; + + (* FlexDLL *) + if BaseStandardVar.os_type () = "Win32" || + BaseStandardVar.os_type () = "Cygwin" then + begin + try + var_ignore_eval BaseStandardVar.flexlink + with e -> + warn_exception e; + add_errors (f_ "Cannot find 'flexlink'") + end; + + (* Check build depends *) + List.iter + (function + | Executable (_, bs, _) + | Library (_, bs, _) as sct -> + build_checks sct bs + | Doc (_, doc) -> + if var_choose doc.doc_build then + check_tools doc.doc_build_tools + | Test (_, test) -> + if var_choose test.test_run then + check_tools test.test_tools + | _ -> + ()) + pkg.sections; + + (* Check if we need native dynlink (presence of libraries that compile to + * native) + *) + begin + let has_cmxa = + List.exists + (function + | Library (_, bs, _) -> + var_choose bs.bs_build && + (bs.bs_compiled_object = Native || + (bs.bs_compiled_object = Best && + bool_of_string (BaseStandardVar.is_native ()))) + | _ -> + false) + pkg.sections + in + if has_cmxa then + var_ignore_eval BaseStandardVar.native_dynlink + end; + + (* Check errors *) + if SetString.empty != !errors then + begin + List.iter + (fun e -> error "%s" e) + (SetString.elements !errors); + failwithf + (fn_ + "%d configuration error" + "%d configuration errors" + (SetString.cardinal !errors)) + (SetString.cardinal !errors) + end + +end + +module InternalInstallPlugin = struct +(* # 21 "src/plugins/internal/InternalInstallPlugin.ml" *) + + (** Install using internal scheme + @author Sylvain Le Gall + *) + + open BaseEnv + open BaseStandardVar + open BaseMessage + open OASISTypes + open OASISFindlib + open OASISGettext + open OASISUtils + + let exec_hook = + ref (fun (cs, bs, exec) -> cs, bs, exec) + + let lib_hook = + ref (fun (cs, bs, lib) -> cs, bs, lib, []) + + let obj_hook = + ref (fun (cs, bs, obj) -> cs, bs, obj, []) + + let doc_hook = + ref (fun (cs, doc) -> cs, doc) + + let install_file_ev = + "install-file" + + let install_dir_ev = + "install-dir" + + let install_findlib_ev = + "install-findlib" + + let win32_max_command_line_length = 8000 + + let split_install_command ocamlfind findlib_name meta files = + if Sys.os_type = "Win32" then + (* Arguments for the first command: *) + let first_args = ["install"; findlib_name; meta] in + (* Arguments for remaining commands: *) + let other_args = ["install"; findlib_name; "-add"] in + (* Extract as much files as possible from [files], [len] is + the current command line length: *) + let rec get_files len acc files = + match files with + | [] -> + (List.rev acc, []) + | file :: rest -> + let len = len + 1 + String.length file in + if len > win32_max_command_line_length then + (List.rev acc, files) + else + get_files len (file :: acc) rest + in + (* Split the command into several commands. *) + let rec split args files = + match files with + | [] -> + [] + | _ -> + (* Length of "ocamlfind install [META|-add]" *) + let len = + List.fold_left + (fun len arg -> + len + 1 (* for the space *) + String.length arg) + (String.length ocamlfind) + args + in + match get_files len [] files with + | ([], _) -> + failwith (s_ "Command line too long.") + | (firsts, others) -> + let cmd = args @ firsts in + (* Use -add for remaining commands: *) + let () = + let findlib_ge_132 = + OASISVersion.comparator_apply + (OASISVersion.version_of_string + (BaseStandardVar.findlib_version ())) + (OASISVersion.VGreaterEqual + (OASISVersion.version_of_string "1.3.2")) + in + if not findlib_ge_132 then + failwithf + (f_ "Installing the library %s require to use the flag \ + '-add' of ocamlfind because the command line is too \ + long. This flag is only available for findlib 1.3.2. \ + Please upgrade findlib from %s to 1.3.2") + findlib_name (BaseStandardVar.findlib_version ()) + in + let cmds = split other_args others in + cmd :: cmds + in + (* The first command does not use -add: *) + split first_args files + else + ["install" :: findlib_name :: meta :: files] + + let install pkg argv = + + let in_destdir = + try + let destdir = + destdir () + in + (* Practically speaking destdir is prepended + * at the beginning of the target filename + *) + fun fn -> destdir^fn + with PropList.Not_set _ -> + fun fn -> fn + in + + let install_file ?tgt_fn src_file envdir = + let tgt_dir = + in_destdir (envdir ()) + in + let tgt_file = + Filename.concat + tgt_dir + (match tgt_fn with + | Some fn -> + fn + | None -> + Filename.basename src_file) + in + (* Create target directory if needed *) + OASISFileUtil.mkdir_parent + ~ctxt:!BaseContext.default + (fun dn -> + info (f_ "Creating directory '%s'") dn; + BaseLog.register install_dir_ev dn) + tgt_dir; + + (* Really install files *) + info (f_ "Copying file '%s' to '%s'") src_file tgt_file; + OASISFileUtil.cp ~ctxt:!BaseContext.default src_file tgt_file; + BaseLog.register install_file_ev tgt_file + in + + (* Install data into defined directory *) + let install_data srcdir lst tgtdir = + let tgtdir = + OASISHostPath.of_unix (var_expand tgtdir) + in + List.iter + (fun (src, tgt_opt) -> + let real_srcs = + OASISFileUtil.glob + ~ctxt:!BaseContext.default + (Filename.concat srcdir src) + in + if real_srcs = [] then + failwithf + (f_ "Wildcard '%s' doesn't match any files") + src; + List.iter + (fun fn -> + install_file + fn + (fun () -> + match tgt_opt with + | Some s -> + OASISHostPath.of_unix (var_expand s) + | None -> + tgtdir)) + real_srcs) + lst + in + + (** Install all libraries *) + let install_libs pkg = + + let files_of_library (f_data, acc) data_lib = + let cs, bs, lib, lib_extra = + !lib_hook data_lib + in + if var_choose bs.bs_install && + BaseBuilt.is_built BaseBuilt.BLib cs.cs_name then + begin + let acc = + (* Start with acc + lib_extra *) + List.rev_append lib_extra acc + in + let acc = + (* Add uncompiled header from the source tree *) + let path = + OASISHostPath.of_unix bs.bs_path + in + List.fold_left + (fun acc modul -> + try + List.find + OASISFileUtil.file_exists_case + (List.map + (Filename.concat path) + [modul^".mli"; + modul^".ml"; + String.uncapitalize modul^".mli"; + String.capitalize modul^".mli"; + String.uncapitalize modul^".ml"; + String.capitalize modul^".ml"]) + :: acc + with Not_found -> + begin + warning + (f_ "Cannot find source header for module %s \ + in library %s") + modul cs.cs_name; + acc + end) + acc + lib.lib_modules + in + + let acc = + (* Get generated files *) + BaseBuilt.fold + BaseBuilt.BLib + cs.cs_name + (fun acc fn -> fn :: acc) + acc + in + + let f_data () = + (* Install data associated with the library *) + install_data + bs.bs_path + bs.bs_data_files + (Filename.concat + (datarootdir ()) + pkg.name); + f_data () + in + + (f_data, acc) + end + else + begin + (f_data, acc) + end + and files_of_object (f_data, acc) data_obj = + let cs, bs, obj, obj_extra = + !obj_hook data_obj + in + if var_choose bs.bs_install && + BaseBuilt.is_built BaseBuilt.BObj cs.cs_name then + begin + let acc = + (* Start with acc + obj_extra *) + List.rev_append obj_extra acc + in + let acc = + (* Add uncompiled header from the source tree *) + let path = + OASISHostPath.of_unix bs.bs_path + in + List.fold_left + (fun acc modul -> + try + List.find + OASISFileUtil.file_exists_case + (List.map + (Filename.concat path) + [modul^".mli"; + modul^".ml"; + String.uncapitalize modul^".mli"; + String.capitalize modul^".mli"; + String.uncapitalize modul^".ml"; + String.capitalize modul^".ml"]) + :: acc + with Not_found -> + begin + warning + (f_ "Cannot find source header for module %s \ + in object %s") + modul cs.cs_name; + acc + end) + acc + obj.obj_modules + in + + let acc = + (* Get generated files *) + BaseBuilt.fold + BaseBuilt.BObj + cs.cs_name + (fun acc fn -> fn :: acc) + acc + in + + let f_data () = + (* Install data associated with the object *) + install_data + bs.bs_path + bs.bs_data_files + (Filename.concat + (datarootdir ()) + pkg.name); + f_data () + in + + (f_data, acc) + end + else + begin + (f_data, acc) + end + + in + + (* Install one group of library *) + let install_group_lib grp = + (* Iterate through all group nodes *) + let rec install_group_lib_aux data_and_files grp = + let data_and_files, children = + match grp with + | Container (_, children) -> + data_and_files, children + | Package (_, cs, bs, `Library lib, children) -> + files_of_library data_and_files (cs, bs, lib), children + | Package (_, cs, bs, `Object obj, children) -> + files_of_object data_and_files (cs, bs, obj), children + in + List.fold_left + install_group_lib_aux + data_and_files + children + in + + (* Findlib name of the root library *) + let findlib_name = + findlib_of_group grp + in + + (* Determine root library *) + let root_lib = + root_of_group grp + in + + (* All files to install for this library *) + let f_data, files = + install_group_lib_aux (ignore, []) grp + in + + (* Really install, if there is something to install *) + if files = [] then + begin + warning + (f_ "Nothing to install for findlib library '%s'") + findlib_name + end + else + begin + let meta = + (* Search META file *) + let (_, bs, _) = + root_lib + in + let res = + Filename.concat bs.bs_path "META" + in + if not (OASISFileUtil.file_exists_case res) then + failwithf + (f_ "Cannot find file '%s' for findlib library %s") + res + findlib_name; + res + in + let files = + (* Make filename shorter to avoid hitting command max line length + * too early, esp. on Windows. + *) + let remove_prefix p n = + let plen = String.length p in + let nlen = String.length n in + if plen <= nlen && String.sub n 0 plen = p then + begin + let fn_sep = + if Sys.os_type = "Win32" then + '\\' + else + '/' + in + let cutpoint = plen + + (if plen < nlen && n.[plen] = fn_sep then + 1 + else + 0) + in + String.sub n cutpoint (nlen - cutpoint) + end + else + n + in + List.map (remove_prefix (Sys.getcwd ())) files + in + info + (f_ "Installing findlib library '%s'") + findlib_name; + let ocamlfind = ocamlfind () in + let commands = + split_install_command + ocamlfind + findlib_name + meta + files + in + List.iter + (OASISExec.run ~ctxt:!BaseContext.default ocamlfind) + commands; + BaseLog.register install_findlib_ev findlib_name + end; + + (* Install data files *) + f_data (); + + in + + let group_libs, _, _ = + findlib_mapping pkg + in + + (* We install libraries in groups *) + List.iter install_group_lib group_libs + in + + let install_execs pkg = + let install_exec data_exec = + let (cs, bs, exec) = + !exec_hook data_exec + in + if var_choose bs.bs_install && + BaseBuilt.is_built BaseBuilt.BExec cs.cs_name then + begin + let exec_libdir () = + Filename.concat + (libdir ()) + pkg.name + in + BaseBuilt.fold + BaseBuilt.BExec + cs.cs_name + (fun () fn -> + install_file + ~tgt_fn:(cs.cs_name ^ ext_program ()) + fn + bindir) + (); + BaseBuilt.fold + BaseBuilt.BExecLib + cs.cs_name + (fun () fn -> + install_file + fn + exec_libdir) + (); + install_data + bs.bs_path + bs.bs_data_files + (Filename.concat + (datarootdir ()) + pkg.name) + end + in + List.iter + (function + | Executable (cs, bs, exec)-> + install_exec (cs, bs, exec) + | _ -> + ()) + pkg.sections + in + + let install_docs pkg = + let install_doc data = + let (cs, doc) = + !doc_hook data + in + if var_choose doc.doc_install && + BaseBuilt.is_built BaseBuilt.BDoc cs.cs_name then + begin + let tgt_dir = + OASISHostPath.of_unix (var_expand doc.doc_install_dir) + in + BaseBuilt.fold + BaseBuilt.BDoc + cs.cs_name + (fun () fn -> + install_file + fn + (fun () -> tgt_dir)) + (); + install_data + Filename.current_dir_name + doc.doc_data_files + doc.doc_install_dir + end + in + List.iter + (function + | Doc (cs, doc) -> + install_doc (cs, doc) + | _ -> + ()) + pkg.sections + in + + install_libs pkg; + install_execs pkg; + install_docs pkg + + (* Uninstall already installed data *) + let uninstall _ argv = + List.iter + (fun (ev, data) -> + if ev = install_file_ev then + begin + if OASISFileUtil.file_exists_case data then + begin + info + (f_ "Removing file '%s'") + data; + Sys.remove data + end + else + begin + warning + (f_ "File '%s' doesn't exist anymore") + data + end + end + else if ev = install_dir_ev then + begin + if Sys.file_exists data && Sys.is_directory data then + begin + if Sys.readdir data = [||] then + begin + info + (f_ "Removing directory '%s'") + data; + OASISFileUtil.rmdir ~ctxt:!BaseContext.default data + end + else + begin + warning + (f_ "Directory '%s' is not empty (%s)") + data + (String.concat + ", " + (Array.to_list + (Sys.readdir data))) + end + end + else + begin + warning + (f_ "Directory '%s' doesn't exist anymore") + data + end + end + else if ev = install_findlib_ev then + begin + info (f_ "Removing findlib library '%s'") data; + OASISExec.run ~ctxt:!BaseContext.default + (ocamlfind ()) ["remove"; data] + end + else + failwithf (f_ "Unknown log event '%s'") ev; + BaseLog.unregister ev data) + (* We process event in reverse order *) + (List.rev + (BaseLog.filter + [install_file_ev; + install_dir_ev; + install_findlib_ev;])) + +end + + +# 5458 "setup.ml" +module OCamlbuildCommon = struct +(* # 21 "src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) + + (** Functions common to OCamlbuild build and doc plugin + *) + + open OASISGettext + open BaseEnv + open BaseStandardVar + + let ocamlbuild_clean_ev = + "ocamlbuild-clean" + + let ocamlbuildflags = + var_define + ~short_desc:(fun () -> "OCamlbuild additional flags") + "ocamlbuildflags" + (fun () -> "") + + (** Fix special arguments depending on environment *) + let fix_args args extra_argv = + List.flatten + [ + if (os_type ()) = "Win32" then + [ + "-classic-display"; + "-no-log"; + "-no-links"; + "-install-lib-dir"; + (Filename.concat (standard_library ()) "ocamlbuild") + ] + else + []; + + if not (bool_of_string (is_native ())) || (os_type ()) = "Win32" then + [ + "-byte-plugin" + ] + else + []; + args; + + if bool_of_string (debug ()) then + ["-tag"; "debug"] + else + []; + + if bool_of_string (profile ()) then + ["-tag"; "profile"] + else + []; + + OASISString.nsplit (ocamlbuildflags ()) ' '; + + Array.to_list extra_argv; + ] + + (** Run 'ocamlbuild -clean' if not already done *) + let run_clean extra_argv = + let extra_cli = + String.concat " " (Array.to_list extra_argv) + in + (* Run if never called with these args *) + if not (BaseLog.exists ocamlbuild_clean_ev extra_cli) then + begin + OASISExec.run ~ctxt:!BaseContext.default + (ocamlbuild ()) (fix_args ["-clean"] extra_argv); + BaseLog.register ocamlbuild_clean_ev extra_cli; + at_exit + (fun () -> + try + BaseLog.unregister ocamlbuild_clean_ev extra_cli + with _ -> + ()) + end + + (** Run ocamlbuild, unregister all clean events *) + let run_ocamlbuild args extra_argv = + (* TODO: enforce that target in args must be UNIX encoded i.e. toto/index.html + *) + OASISExec.run ~ctxt:!BaseContext.default + (ocamlbuild ()) (fix_args args extra_argv); + (* Remove any clean event, we must run it again *) + List.iter + (fun (e, d) -> BaseLog.unregister e d) + (BaseLog.filter [ocamlbuild_clean_ev]) + + (** Determine real build directory *) + let build_dir extra_argv = + let rec search_args dir = + function + | "-build-dir" :: dir :: tl -> + search_args dir tl + | _ :: tl -> + search_args dir tl + | [] -> + dir + in + search_args "_build" (fix_args [] extra_argv) + +end + +module OCamlbuildPlugin = struct +(* # 21 "src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) + + (** Build using ocamlbuild + @author Sylvain Le Gall + *) + + open OASISTypes + open OASISGettext + open OASISUtils + open BaseEnv + open OCamlbuildCommon + open BaseStandardVar + open BaseMessage + + let cond_targets_hook = + ref (fun lst -> lst) + + let build pkg argv = + + (* Return the filename in build directory *) + let in_build_dir fn = + Filename.concat + (build_dir argv) + fn + in + + (* Return the unix filename in host build directory *) + let in_build_dir_of_unix fn = + in_build_dir (OASISHostPath.of_unix fn) + in + + (* Checks if the string [fn] ends with [nd] *) + let ends_with nd fn = + let nd_len = + String.length nd + in + (String.length fn >= nd_len) + && + (String.sub + fn + (String.length fn - nd_len) + nd_len) = nd + in + + let cond_targets = + List.fold_left + (fun acc -> + function + | Library (cs, bs, lib) when var_choose bs.bs_build -> + begin + let evs, unix_files = + BaseBuilt.of_library + in_build_dir_of_unix + (cs, bs, lib) + in + + let tgts = + List.flatten + (List.filter + (fun l -> l <> []) + (List.map + (List.filter + (fun fn -> + ends_with ".cma" fn + || ends_with ".cmxs" fn + || ends_with ".cmxa" fn + || ends_with (ext_lib ()) fn + || ends_with (ext_dll ()) fn)) + unix_files)) + in + + match tgts with + | _ :: _ -> + (evs, tgts) :: acc + | [] -> + failwithf + (f_ "No possible ocamlbuild targets for library %s") + cs.cs_name + end + + | Object (cs, bs, obj) when var_choose bs.bs_build -> + begin + let evs, unix_files = + BaseBuilt.of_object + in_build_dir_of_unix + (cs, bs, obj) + in + + let tgts = + List.flatten + (List.filter + (fun l -> l <> []) + (List.map + (List.filter + (fun fn -> + ends_with ".cmo" fn + || ends_with ".cmx" fn)) + unix_files)) + in + + match tgts with + | _ :: _ -> + (evs, tgts) :: acc + | [] -> + failwithf + (f_ "No possible ocamlbuild targets for object %s") + cs.cs_name + end + + | Executable (cs, bs, exec) when var_choose bs.bs_build -> + begin + let evs, unix_exec_is, unix_dll_opt = + BaseBuilt.of_executable + in_build_dir_of_unix + (cs, bs, exec) + in + + let target ext = + let unix_tgt = + (OASISUnixPath.concat + bs.bs_path + (OASISUnixPath.chop_extension + exec.exec_main_is))^ext + in + let evs = + (* Fix evs, we want to use the unix_tgt, without copying *) + List.map + (function + | BaseBuilt.BExec, nm, lst when nm = cs.cs_name -> + BaseBuilt.BExec, nm, [[in_build_dir_of_unix unix_tgt]] + | ev -> + ev) + evs + in + evs, [unix_tgt] + in + + (* Add executable *) + let acc = + match bs.bs_compiled_object with + | Native_object -> + (target ".nobj.o") :: acc + | Bytecode_object -> + (target ".bobj.o") :: acc + | Native -> + (target ".native") :: acc + | Best when bool_of_string (is_native ()) -> + (target ".native") :: acc + | Byte + | Best -> + (target ".byte") :: acc + in + acc + end + + | Library _ | Object _ | Executable _ | Test _ + | SrcRepo _ | Flag _ | Doc _ -> + acc) + [] + (* Keep the pkg.sections ordered *) + (List.rev pkg.sections); + in + + (* Check and register built files *) + let check_and_register (bt, bnm, lst) = + List.iter + (fun fns -> + if not (List.exists OASISFileUtil.file_exists_case fns) then + failwithf + (f_ "No one of expected built files %s exists") + (String.concat (s_ ", ") (List.map (Printf.sprintf "'%s'") fns))) + lst; + (BaseBuilt.register bt bnm lst) + in + + let cond_targets = + (* Run the hook *) + !cond_targets_hook cond_targets + in + + (* Run a list of target... *) + run_ocamlbuild + (List.flatten + (List.map snd cond_targets)) + argv; + (* ... and register events *) + List.iter + check_and_register + (List.flatten (List.map fst cond_targets)) + + + let clean pkg extra_args = + run_clean extra_args; + List.iter + (function + | Library (cs, _, _) -> + BaseBuilt.unregister BaseBuilt.BLib cs.cs_name + | Executable (cs, _, _) -> + BaseBuilt.unregister BaseBuilt.BExec cs.cs_name; + BaseBuilt.unregister BaseBuilt.BExecLib cs.cs_name + | _ -> + ()) + pkg.sections + +end + +module OCamlbuildDocPlugin = struct +(* # 21 "src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) + + (* Create documentation using ocamlbuild .odocl files + @author Sylvain Le Gall + *) + + open OASISTypes + open OASISGettext + open OASISMessage + open OCamlbuildCommon + open BaseStandardVar + + + + let doc_build path pkg (cs, doc) argv = + let index_html = + OASISUnixPath.make + [ + path; + cs.cs_name^".docdir"; + "index.html"; + ] + in + let tgt_dir = + OASISHostPath.make + [ + build_dir argv; + OASISHostPath.of_unix path; + cs.cs_name^".docdir"; + ] + in + run_ocamlbuild [index_html] argv; + List.iter + (fun glb -> + BaseBuilt.register + BaseBuilt.BDoc + cs.cs_name + [OASISFileUtil.glob ~ctxt:!BaseContext.default + (Filename.concat tgt_dir glb)]) + ["*.html"; "*.css"] + + let doc_clean t pkg (cs, doc) argv = + run_clean argv; + BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name + +end + + +# 5817 "setup.ml" +open OASISTypes;; + +let setup_t = + { + BaseSetup.configure = InternalConfigurePlugin.configure; + build = OCamlbuildPlugin.build; + test = []; + doc = []; + install = InternalInstallPlugin.install; + uninstall = InternalInstallPlugin.uninstall; + clean = [OCamlbuildPlugin.clean]; + clean_test = []; + clean_doc = []; + distclean = []; + distclean_test = []; + distclean_doc = []; + package = + { + oasis_version = "0.3"; + ocaml_version = None; + findlib_version = None; + name = "ooauth"; + version = "0.1"; + license = + OASISLicense.DEP5License + (OASISLicense.DEP5Unit + { + OASISLicense.license = "ISC"; + excption = None; + version = OASISLicense.NoVersion; + }); + license_file = None; + copyrights = []; + maintainers = []; + authors = ["Jake Donham"; "Vincent Bernardoff"]; + homepage = None; + synopsis = "OAuth for OCaml"; + description = None; + categories = []; + conf_type = (`Configure, "internal", Some "0.3"); + conf_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)]; + }; + build_type = (`Build, "ocamlbuild", Some "0.3"); + build_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)]; + }; + install_type = (`Install, "internal", Some "0.3"); + install_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)]; + }; + uninstall_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)]; + }; + clean_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)]; + }; + distclean_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)]; + }; + files_ab = []; + sections = + [ + Flag + ({ + cs_name = "cohttp"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + flag_description = Some "build the Cohttp library"; + flag_default = [(OASISExpr.EBool true, true)]; + }); + Flag + ({ + cs_name = "ocurl"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + flag_description = Some "build the OCurl library"; + flag_default = [(OASISExpr.EBool true, false)]; + }); + Flag + ({ + cs_name = "ocamlnet"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + flag_description = Some "build the Ocamlnet library"; + flag_default = [(OASISExpr.EBool true, false)]; + }); + Library + ({ + cs_name = "oauth"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, true)]; + bs_path = "lib"; + bs_compiled_object = Best; + bs_build_depends = + [ + FindlibPackage ("cryptokit", None); + FindlibPackage ("uri", None); + FindlibPackage ("re", None) + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + { + lib_modules = + [ + "Oauth_util"; + "Oauth_base32"; + "Oauth_common"; + "Oauth_client" + ]; + lib_pack = false; + lib_internal_modules = []; + lib_findlib_parent = None; + lib_findlib_name = Some "oauth"; + lib_findlib_containers = []; + }); + Library + ({ + cs_name = "oauth_cohttp"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EFlag "cohttp", true) + ]; + bs_install = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EFlag "cohttp", true) + ]; + bs_path = "cohttp"; + bs_compiled_object = Best; + bs_build_depends = + [ + InternalLibrary "oauth"; + FindlibPackage ("cohttp.lwt", None) + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + { + lib_modules = + ["Oauth_cohttp_http"; "Oauth_cohttp_http_client"]; + lib_pack = false; + lib_internal_modules = []; + lib_findlib_parent = Some "oauth"; + lib_findlib_name = Some "cohttp"; + lib_findlib_containers = []; + }) + ]; + plugins = + [(`Extra, "META", Some "0.3"); (`Extra, "DevFiles", Some "0.3")]; + schema_data = PropList.Data.create (); + plugin_data = []; + }; + oasis_fn = Some "_oasis"; + oasis_version = "0.3.1"; + oasis_digest = Some "\241\139U+\240\134[!OI\t\015]\171\192\223"; + oasis_exec = None; + oasis_setup_args = []; + setup_update = false; + };; + +let setup () = BaseSetup.setup setup_t;; + +# 6024 "setup.ml" +(* OASIS_STOP *) +let () = setup ();; From 239e7ccffc5a8a8ec396c9a01b73dae8fc6f8e3d Mon Sep 17 00:00:00 2001 From: Vincent Bernardoff Date: Thu, 3 Oct 2013 18:06:03 +0200 Subject: [PATCH 06/14] Updated .gitignore. --- .gitignore | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/.gitignore b/.gitignore index 9b825a4..a879215 100644 --- a/.gitignore +++ b/.gitignore @@ -2,4 +2,5 @@ **/public_key.pem **/*.byte **/*.native - +setup.data +setup.log From 34195cc5965e694758b416b1434408365e4f0b51 Mon Sep 17 00:00:00 2001 From: Vincent Bernardoff Date: Thu, 3 Oct 2013 19:47:49 +0200 Subject: [PATCH 07/14] term.ie test client working. --- _oasis | 10 ++++++++- _tags | 15 ++++++++++++- cohttp/oauth_cohttp_http_client.ml | 5 +++-- examples/term.ie/Makefile | 5 ----- examples/term.ie/client.ml | 31 ++++++++++++-------------- examples/term.ie/private_key.pem | 16 -------------- lib/oauth.mllib | 3 ++- lib/oauth_client.ml | 5 ++++- lib/oauth_client.mli | 11 ++++++---- lib/oauth_common.ml | 17 ++++++++------- lib/oauth_server.ml | 4 +++- lib/oauth_server.mli | 4 +++- myocamlbuild.ml | 4 ++-- setup.ml | 35 +++++++++++++++++++++++++----- 14 files changed, 100 insertions(+), 65 deletions(-) delete mode 100644 examples/term.ie/Makefile delete mode 100644 examples/term.ie/private_key.pem diff --git a/_oasis b/_oasis index f2b901e..c0a12e7 100644 --- a/_oasis +++ b/_oasis @@ -22,7 +22,7 @@ Flag ocamlnet Library oauth Path: lib Findlibname: oauth - Modules: Oauth_util, Oauth_base32, Oauth_common, Oauth_client + Modules: Oauth_util, Oauth_base32, Oauth_common, Oauth_client, Oauth_server BuildDepends: cryptokit, uri, re Library oauth_cohttp @@ -33,3 +33,11 @@ Library oauth_cohttp Findlibparent: oauth BuildDepends: oauth, cohttp.lwt Modules: Oauth_cohttp_http, Oauth_cohttp_http_client + +Executable client_termie + Path: examples/term.ie + BuildDepends: oauth.cohttp + MainIs: client.ml + CompiledObject: best + Build: true + Install: false diff --git a/_tags b/_tags index cfd4924..8943241 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: 35491c1f6e5569948dbda548078fec08) +# DO NOT EDIT (digest: c636f3eb5d410f078e550e03674170a6) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process @@ -25,4 +25,17 @@ : pkg_cryptokit : pkg_uri : pkg_re +# Executable client_termie +: use_oauth_cohttp +: use_oauth +: pkg_cohttp.lwt +: pkg_cryptokit +: pkg_uri +: pkg_re +: use_oauth_cohttp +: use_oauth +: pkg_cohttp.lwt +: pkg_cryptokit +: pkg_uri +: pkg_re # OASIS_STOP diff --git a/cohttp/oauth_cohttp_http_client.ml b/cohttp/oauth_cohttp_http_client.ml index 768b899..cb52df2 100644 --- a/cohttp/oauth_cohttp_http_client.ml +++ b/cohttp/oauth_cohttp_http_client.ml @@ -4,7 +4,8 @@ module CB = Cohttp_lwt_body let (>>=) = Lwt.bind -type status = C.Code.status +type status = C.Code.status_code +type meth = C.Code.meth module Opt = struct type 'a t = 'a option @@ -24,7 +25,7 @@ let request ?http_method ~url ?headers ?params ?body () = in CU.Client.call ?headers:Opt.(headers >|= fun hs -> C.Header.of_list hs) - ?body:Opt.(body >>= fun b -> CB.body_of_string b) + ?body:Opt.(body >>= fun (content_type, body) -> CB.body_of_string body) Opt.(default `GET http_method) uri >>= function diff --git a/examples/term.ie/Makefile b/examples/term.ie/Makefile deleted file mode 100644 index c3686f8..0000000 --- a/examples/term.ie/Makefile +++ /dev/null @@ -1,5 +0,0 @@ -all: - ocamlbuild -use-ocamlfind client.byte - -clean: - ocamlbuild -clean diff --git a/examples/term.ie/client.ml b/examples/term.ie/client.ml index d70cde1..676e299 100644 --- a/examples/term.ie/client.ml +++ b/examples/term.ie/client.ml @@ -1,32 +1,30 @@ (* works against the term.ie test server *) -module OC = Oauth_client.Make(Oauth_netclient_http_client) +module OC = Oauth_client.Make(Oauth_cohttp_http_client) -let rsa_key = Rsa.read_rsa_privkey "private_key.pem" +let (>>=) = Lwt.bind (* from http://term.ie/oauth/example *) let oauth_consumer_key = "key" let oauth_consumer_secret = "secret" -let oauth_signature_method = `Rsa_sha1 rsa_key -let http_method = `Post +let oauth_signature_method = `Hmac_sha1 +let http_method = `POST let url s = "http://term.ie/oauth/example" ^ s let fetch_request_token () = - let oauth_token, oauth_token_secret = OC.fetch_request_token ~http_method ~url:(url "/request_token.php") ~oauth_signature_method ~oauth_consumer_key ~oauth_consumer_secret - () in + () >>= fun (oauth_token, oauth_token_secret) -> prerr_endline ("oauth_token = " ^ oauth_token); prerr_endline ("oauth_token_secret = " ^ oauth_token_secret); - oauth_token, oauth_token_secret + Lwt.return (oauth_token, oauth_token_secret) let fetch_access_token oauth_token oauth_token_secret = - let oauth_token, oauth_token_secret = OC.fetch_access_token ~http_method ~url:(url "/access_token.php") @@ -35,13 +33,12 @@ let fetch_access_token oauth_token oauth_token_secret = ~oauth_consumer_secret ~oauth_token ~oauth_token_secret - () in + () >>= fun (oauth_token, oauth_token_secret) -> prerr_endline ("oauth_token = " ^ oauth_token); prerr_endline ("oauth_token_secret = " ^ oauth_token_secret); - oauth_token, oauth_token_secret + Lwt.return (oauth_token, oauth_token_secret) let access_resource oauth_token oauth_token_secret = - let res = OC.access_resource ~http_method ~url:(url "/echo_api.php") ~oauth_signature_method @@ -50,10 +47,10 @@ let access_resource oauth_token oauth_token_secret = ~oauth_token ~oauth_token_secret ~params:["method", "foo"; "bar", "baz"] - () in - prerr_endline ("res = " ^ res) + () >>= fun res -> + Lwt_io.eprintl ("res = " ^ res) -let _ = - let t, st = fetch_request_token () in - let t, st = fetch_access_token t st in - access_resource t st +let _ = Lwt_main.run + (fetch_request_token () >>= fun (t, st) -> + fetch_access_token t st >>= fun (t, st) -> + access_resource t st) diff --git a/examples/term.ie/private_key.pem b/examples/term.ie/private_key.pem deleted file mode 100644 index 8d485b8..0000000 --- a/examples/term.ie/private_key.pem +++ /dev/null @@ -1,16 +0,0 @@ ------BEGIN PRIVATE KEY----- -MIICdgIBADANBgkqhkiG9w0BAQEFAASCAmAwggJcAgEAAoGBALRiMLAh9iimur8V -A7qVvdqxevEuUkW4K+2KdMXmnQbG9Aa7k7eBjK1S+0LYmVjPKlJGNXHDGuy5Fw/d -7rjVJ0BLB+ubPK8iA/Tw3hLQgXMRRGRXXCn8ikfuQfjUS1uZSatdLB81mydBETlJ -hI6GH4twrbDJCR2Bwy/XWXgqgGRzAgMBAAECgYBYWVtleUzavkbrPjy0T5FMou8H -X9u2AC2ry8vD/l7cqedtwMPp9k7TubgNFo+NGvKsl2ynyprOZR1xjQ7WgrgVB+mm -uScOM/5HVceFuGRDhYTCObE+y1kxRloNYXnx3ei1zbeYLPCHdhxRYW7T0qcynNmw -rn05/KO2RLjgQNalsQJBANeA3Q4Nugqy4QBUCEC09SqylT2K9FrrItqL2QKc9v0Z -zO2uwllCbg0dwpVuYPYXYvikNHHg+aCWF+VXsb9rpPsCQQDWR9TT4ORdzoj+Nccn -qkMsDmzt0EfNaAOwHOmVJ2RVBspPcxt5iN4HI7HNeG6U5YsFBb+/GZbgfBT3kpNG -WPTpAkBI+gFhjfJvRw38n3g/+UeAkwMI2TJQS4n8+hid0uus3/zOjDySH3XHCUno -cn1xOJAyZODBo47E+67R4jV1/gzbAkEAklJaspRPXP877NssM5nAZMU0/O/NGCZ+ -3jPgDUno6WbJn5cqm8MqWhW1xGkImgRk+fkDBquiq4gPiT898jusgQJAd5Zrr6Q8 -AO/0isr/3aa6O6NLQxISLKcPDk2NOccAfS/xOtfOz4sJYM3+Bs4Io9+dZGSDCA54 -Lw03eHTNQghS0A== ------END PRIVATE KEY----- diff --git a/lib/oauth.mllib b/lib/oauth.mllib index b195350..2db698a 100644 --- a/lib/oauth.mllib +++ b/lib/oauth.mllib @@ -1,7 +1,8 @@ # OASIS_START -# DO NOT EDIT (digest: 585e4ab866bc1003b3f80308f654d541) +# DO NOT EDIT (digest: e29edd7efe0993c3e9d35403d1a90eaf) Oauth_util Oauth_base32 Oauth_common Oauth_client +Oauth_server # OASIS_STOP diff --git a/lib/oauth_client.ml b/lib/oauth_client.ml index d92a0fd..889fec7 100644 --- a/lib/oauth_client.ml +++ b/lib/oauth_client.ml @@ -12,6 +12,7 @@ sig [ `Accepted | `Bad_gateway | `Bad_request + | `Code of int | `Conflict | `Continue | `Created @@ -51,8 +52,10 @@ sig | `Unsupported_media_type | `Use_proxy ] + type meth = [ `DELETE | `GET | `HEAD | `PATCH | `POST | `PUT ] + val request : - ?http_method:[ `GET | `HEAD | `POST ] -> + ?http_method:meth -> url:string -> ?headers:(string * string) list -> ?params:(string * string) list -> diff --git a/lib/oauth_client.mli b/lib/oauth_client.mli index 37ba84e..b221438 100644 --- a/lib/oauth_client.mli +++ b/lib/oauth_client.mli @@ -12,6 +12,7 @@ sig [ `Accepted | `Bad_gateway | `Bad_request + | `Code of int | `Conflict | `Continue | `Created @@ -51,8 +52,10 @@ sig | `Unsupported_media_type | `Use_proxy ] + type meth = [ `DELETE | `GET | `HEAD | `PATCH | `POST | `PUT ] + val request : - ?http_method:[ `GET | `HEAD | `POST ] -> + ?http_method:meth -> url:string -> ?headers:(string * string) list -> ?params:(string * string) list -> @@ -67,7 +70,7 @@ sig exception Error of Http_client.status * string val fetch_request_token : - ?http_method:[ `GET | `HEAD | `POST ] -> + ?http_method:Http_client.meth -> url:string -> ?oauth_version:string -> ?oauth_signature_method:[ `Plaintext | `Hmac_sha1 | `Rsa_sha1 of Cryptokit.RSA.key ] -> @@ -81,7 +84,7 @@ sig (string * string) Http_client.Monad.t val fetch_access_token : - ?http_method:[ `GET | `HEAD | `POST ] -> + ?http_method:Http_client.meth -> url:string -> ?oauth_version:string -> ?oauth_signature_method:[ `Plaintext | `Hmac_sha1 | `Rsa_sha1 of Cryptokit.RSA.key ] -> @@ -96,7 +99,7 @@ sig (string * string) Http_client.Monad.t val access_resource : - ?http_method:[ `GET | `HEAD | `POST ] -> + ?http_method:Http_client.meth -> url:string -> ?oauth_version:string -> ?oauth_signature_method:[ `Plaintext | `Hmac_sha1 | `Rsa_sha1 of Cryptokit.RSA.key ] -> diff --git a/lib/oauth_common.ml b/lib/oauth_common.ml index 10660c6..1999221 100644 --- a/lib/oauth_common.ml +++ b/lib/oauth_common.ml @@ -1,5 +1,3 @@ -let (|>) x f = f x (* so function pipelines read left to right *) - let opt_param name param = match param with | None -> [] @@ -14,6 +12,10 @@ let string_of_http_method = function | `GET -> "GET" | `POST -> "POST" | `HEAD -> "HEAD" + | `DELETE -> "DELETE" + | `OPTIONS -> "OPTIONS" + | `PATCH -> "PATCH" + | `PUT -> "PUT" let string_of_signature_method = function | `Plaintext -> "PLAINTEXT" @@ -24,7 +26,7 @@ let signature_method_of_string rsa_key = function | "PLAINTEXT" -> `Plaintext | "HMAC-SHA1" -> `Hmac_sha1 | "RSA-SHA1" -> `Rsa_sha1 (rsa_key ()) - | _ -> raise Not_found + | _ -> raise (Invalid_argument "Not a signature method") let normalize_url url = let open Uri in @@ -40,19 +42,18 @@ let make_timestamp () = Unix.time () let make_nonce () = Cryptokit.Random.string rng 16 |> - Cryptokit.transform_string (Cryptokit.Hexa.encode ()) + Cryptokit.transform_string (Cryptokit.Hexa.encode ()) let base64_encode v = - let b64 = Cryptokit.transform_string (Cryptokit.Base64.encode_compact ()) v in - b64 ^ "=" + Cryptokit.transform_string (Cryptokit.Base64.encode_compact_pad ()) v let base64_decode v = Cryptokit.transform_string (Cryptokit.Base64.decode ()) v let hmac_sha1_hash text key = text |> - Cryptokit.hash_string (Cryptokit.MAC.hmac_sha1 key) |> - base64_encode + Cryptokit.hash_string (Cryptokit.MAC.hmac_sha1 key) |> + base64_encode let sha1_digest_info h = "\x30\x21\x30\x09\x06\x05\x2b\x0e\x03\x02\x1a\x05\x00\x04\x14" ^ h diff --git a/lib/oauth_server.ml b/lib/oauth_server.ml index 0bbb13d..e67f3ec 100644 --- a/lib/oauth_server.ml +++ b/lib/oauth_server.ml @@ -51,8 +51,10 @@ sig | `Unsupported_media_type | `Use_proxy ] + type meth = [ `DELETE | `GET | `HEAD | `OPTIONS | `PATCH | `POST | `PUT ] + type request - val http_method : request -> [ `GET | `POST | `HEAD ] + val http_method : request -> meth val url : request -> string val header : request -> string -> string (* throws Not_found *) val argument : request -> ?default:string -> string -> string (* throws Not_found *) diff --git a/lib/oauth_server.mli b/lib/oauth_server.mli index af4bdb6..e01ae0b 100644 --- a/lib/oauth_server.mli +++ b/lib/oauth_server.mli @@ -51,8 +51,10 @@ sig | `Unsupported_media_type | `Use_proxy ] + type meth = [ `DELETE | `GET | `HEAD | `OPTIONS | `PATCH | `POST | `PUT ] + type request - val http_method : request -> [ `GET | `POST | `HEAD ] + val http_method : request -> meth val url : request -> string val header : request -> string -> string (* throws Not_found *) val argument : request -> ?default:string -> string -> string (* throws Not_found *) diff --git a/myocamlbuild.ml b/myocamlbuild.ml index d1f7e26..3b30669 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,5 +1,5 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: 6f55567a591f9c6aae89e1411a71e9c6) *) +(* DO NOT EDIT (digest: be1e2bc21542ae2c00be7784919c1784) *) module OASISGettext = struct (* # 21 "src/oasis/OASISGettext.ml" *) @@ -511,7 +511,7 @@ let package_default = [("oauth", ["lib"]); ("oauth_cohttp", ["cohttp"])]; lib_c = []; flags = []; - includes = [("cohttp", ["lib"])]; + includes = [("examples/term.ie", ["cohttp"]); ("cohttp", ["lib"])]; } ;; diff --git a/setup.ml b/setup.ml index 9608c2d..e176dae 100644 --- a/setup.ml +++ b/setup.ml @@ -1,7 +1,7 @@ (* setup.ml generated for the first time by OASIS v0.3.1 *) (* OASIS_START *) -(* DO NOT EDIT (digest: c53df64906da444f8e1ed5a07d0849c8) *) +(* DO NOT EDIT (digest: 20e59aff89ada419f8b47d0534cedb3d) *) (* Regenerated by OASIS v0.3.1 Visit http://oasis.forge.ocamlcore.org for more information and @@ -5953,7 +5953,8 @@ let setup_t = "Oauth_util"; "Oauth_base32"; "Oauth_common"; - "Oauth_client" + "Oauth_client"; + "Oauth_server" ]; lib_pack = false; lib_internal_modules = []; @@ -6003,7 +6004,30 @@ let setup_t = lib_findlib_parent = Some "oauth"; lib_findlib_name = Some "cohttp"; lib_findlib_containers = []; - }) + }); + Executable + ({ + cs_name = "client_termie"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, false)]; + bs_path = "examples/term.ie"; + bs_compiled_object = Best; + bs_build_depends = [InternalLibrary "oauth_cohttp"]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + {exec_custom = false; exec_main_is = "client.ml"; }) ]; plugins = [(`Extra, "META", Some "0.3"); (`Extra, "DevFiles", Some "0.3")]; @@ -6012,7 +6036,8 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.3.1"; - oasis_digest = Some "\241\139U+\240\134[!OI\t\015]\171\192\223"; + oasis_digest = + Some "\226\202\211\251S:\245\157\170\210\202\194\221\215Jn"; oasis_exec = None; oasis_setup_args = []; setup_update = false; @@ -6020,6 +6045,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 6024 "setup.ml" +# 6049 "setup.ml" (* OASIS_STOP *) let () = setup ();; From f0f37498ef191c504e96c77f6f6d903774ff3985 Mon Sep 17 00:00:00 2001 From: Vincent Bernardoff Date: Thu, 3 Oct 2013 19:51:15 +0200 Subject: [PATCH 08/14] Replaced the rng by a less entropy-hungry one. --- lib/oauth_common.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lib/oauth_common.ml b/lib/oauth_common.ml index 1999221..fc42e32 100644 --- a/lib/oauth_common.ml +++ b/lib/oauth_common.ml @@ -3,7 +3,8 @@ let opt_param name param = | None -> [] | Some p -> [name, p] -let rng = Cryptokit.Random.device_rng "/dev/random" +(* Good enough and do not eat entropy. *) +let rng = Cryptokit.(Random.pseudo_rng (Random.string Random.secure_rng 20)) let rfc3986_encode = Uri.pct_encode ~component:`Authority let rfc3986_decode = Uri.pct_decode From 05faf7ca445df32b9ce7ce071b2862637ad0d0a1 Mon Sep 17 00:00:00 2001 From: Vincent Bernardoff Date: Thu, 3 Oct 2013 21:03:19 +0200 Subject: [PATCH 09/14] Use /dev/urandom to avoid blocking completely. --- lib/oauth_common.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/oauth_common.ml b/lib/oauth_common.ml index fc42e32..2995bda 100644 --- a/lib/oauth_common.ml +++ b/lib/oauth_common.ml @@ -4,7 +4,7 @@ let opt_param name param = | Some p -> [name, p] (* Good enough and do not eat entropy. *) -let rng = Cryptokit.(Random.pseudo_rng (Random.string Random.secure_rng 20)) +let rng = Cryptokit.(Random.device_rng "/dev/urandom") let rfc3986_encode = Uri.pct_encode ~component:`Authority let rfc3986_decode = Uri.pct_decode From 35f5874c16f5390c0129fe71f1ba631388e52f9e Mon Sep 17 00:00:00 2001 From: Vincent Bernardoff Date: Thu, 3 Oct 2013 21:03:43 +0200 Subject: [PATCH 10/14] Fix localhost/client.ml. --- _oasis | 8 +++++ _tags | 15 ++++++++- examples/localhost/Makefile | 11 ------- examples/localhost/certificate.pem | 11 ------- examples/localhost/client.ml | 52 ++++++++++++++++++------------ examples/localhost/private_key.pem | 16 --------- myocamlbuild.ml | 11 +++++-- setup.ml | 30 ++++++++++++++--- 8 files changed, 88 insertions(+), 66 deletions(-) delete mode 100644 examples/localhost/Makefile delete mode 100644 examples/localhost/certificate.pem delete mode 100644 examples/localhost/private_key.pem diff --git a/_oasis b/_oasis index c0a12e7..fb9be4a 100644 --- a/_oasis +++ b/_oasis @@ -41,3 +41,11 @@ Executable client_termie CompiledObject: best Build: true Install: false + +Executable client_localhost + Path: examples/localhost + BuildDepends: oauth.cohttp + MainIs: client.ml + CompiledObject: best + Build: true + Install: false diff --git a/_tags b/_tags index 8943241..45ba401 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: c636f3eb5d410f078e550e03674170a6) +# DO NOT EDIT (digest: 0480a2cf5c45074343ea4267ee9ce003) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process @@ -38,4 +38,17 @@ : pkg_cryptokit : pkg_uri : pkg_re +# Executable client_localhost +: use_oauth_cohttp +: use_oauth +: pkg_cohttp.lwt +: pkg_cryptokit +: pkg_uri +: pkg_re +: use_oauth_cohttp +: use_oauth +: pkg_cohttp.lwt +: pkg_cryptokit +: pkg_uri +: pkg_re # OASIS_STOP diff --git a/examples/localhost/Makefile b/examples/localhost/Makefile deleted file mode 100644 index f789f9a..0000000 --- a/examples/localhost/Makefile +++ /dev/null @@ -1,11 +0,0 @@ -.PHONY: all - -all: public_key.pem - ocamlbuild -use-ocamlfind client.byte server.byte - -public_key.pem: certificate.pem - openssl x509 -in certificate.pem -pubkey -noout > public_key.pem - -clean: - ocamlbuild -clean - rm -f public_key.pem diff --git a/examples/localhost/certificate.pem b/examples/localhost/certificate.pem deleted file mode 100644 index 10d14a6..0000000 --- a/examples/localhost/certificate.pem +++ /dev/null @@ -1,11 +0,0 @@ ------BEGIN CERTIFICATE----- -MIIBpjCCAQ+gAwIBAgIBATANBgkqhkiG9w0BAQUFADAZMRcwFQYDVQQDDA5UZXN0 -IFByaW5jaXBhbDAeFw03MDAxMDEwODAwMDBaFw0zODEyMzEwODAwMDBaMBkxFzAV -BgNVBAMMDlRlc3QgUHJpbmNpcGFsMIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKB -gQC0YjCwIfYoprq/FQO6lb3asXrxLlJFuCvtinTF5p0GxvQGu5O3gYytUvtC2JlY -zypSRjVxwxrsuRcP3e641SdASwfrmzyvIgP08N4S0IFzEURkV1wp/IpH7kH41Etb -mUmrXSwfNZsnQRE5SYSOhh+LcK2wyQkdgcMv11l4KoBkcwIDAQABMA0GCSqGSIb3 -DQEBBQUAA4GBAGZLPEuJ5SiJ2ryq+CmEGOXfvlTtEL2nuGtr9PewxkgnOjZpUy+d -4TvuXJbNQc8f4AMWL/tO9w0Fk80rWKp9ea8/df4qMq5qlFWlx6yOLQxumNOmECKb -WpkUQDIDJEoFUzKMVuJf4KO/FJ345+BNLGgbJ6WujreoM1X/gYfdnJ/J ------END CERTIFICATE----- diff --git a/examples/localhost/client.ml b/examples/localhost/client.ml index 8760d62..7faaf55 100644 --- a/examples/localhost/client.ml +++ b/examples/localhost/client.ml @@ -8,45 +8,57 @@ *) module OC = Oauth_client.Make(Oauth_cohttp_http_client) -let rsa_key = Rsa.read_rsa_privkey "private_key.pem" -let oauth_signature_method = `Rsa_sha1 rsa_key +let (>>=) = Lwt.bind + +let oauth_signature_method = `Hmac_sha1 let http_method = `POST let url s = "http://localhost:8767" ^ s -;; - -let (oauth_token, oauth_token_secret) = +let fetch_request_token () = OC.fetch_request_token ~http_method ~url:(url "/request_token") ~oauth_signature_method ~oauth_consumer_key:"key" ~oauth_consumer_secret:"secret" - () in -prerr_endline ("oauth_token = " ^ oauth_token); -prerr_endline ("oauth_token_secret = " ^ oauth_token_secret); + () + >>= fun (oauth_token, oauth_token_secret) -> + prerr_endline ("oauth_token = " ^ oauth_token); + prerr_endline ("oauth_token_secret = " ^ oauth_token_secret); + Lwt.return (oauth_token, oauth_token_secret) -ignore(Oauth_netclient_http_client.request - ~http_method:`Post - ~url:(url "/authorize") - ~params:["oauth_token", oauth_token] - ()); +let authorize oauth_token = + Oauth_cohttp_http_client.request + ~http_method:`POST + ~url:(url "/authorize") + ~params:["oauth_token", oauth_token] + () >>= fun _ -> Lwt.return () -let (oauth_token, oauth_token_secret) = +let fetch_access_token oauth_token oauth_token_secret = OC.fetch_access_token ~http_method ~url:(url "/access_token") ~oauth_signature_method ~oauth_consumer_key:"key" ~oauth_consumer_secret:"secret" ~oauth_token ~oauth_token_secret - () in -prerr_endline ("oauth_token = " ^ oauth_token); -prerr_endline ("oauth_token_secret = " ^ oauth_token_secret); + () + >>= fun (oauth_token, oauth_token_secret) -> + prerr_endline ("oauth_token = " ^ oauth_token); + prerr_endline ("oauth_token_secret = " ^ oauth_token_secret); + Lwt.return (oauth_token, oauth_token_secret) -let res = +let access_resource oauth_token oauth_token_secret = OC.access_resource ~http_method ~url:(url "/echo") ~oauth_signature_method ~oauth_consumer_key:"key" ~oauth_consumer_secret:"secret" ~oauth_token ~oauth_token_secret ~params:["method", "foo"; "bar", "baz"] - () in -prerr_endline ("res = " ^ res); + () >>= fun res -> + prerr_endline ("res = " ^ res); Lwt.return () + +let _ = Lwt_main.run + ( + fetch_request_token () >>= fun (t, ts) -> + authorize t >>= fun () -> + fetch_access_token t ts >>= fun (t, ts) -> + access_resource t ts + ) diff --git a/examples/localhost/private_key.pem b/examples/localhost/private_key.pem deleted file mode 100644 index 8d485b8..0000000 --- a/examples/localhost/private_key.pem +++ /dev/null @@ -1,16 +0,0 @@ ------BEGIN PRIVATE KEY----- -MIICdgIBADANBgkqhkiG9w0BAQEFAASCAmAwggJcAgEAAoGBALRiMLAh9iimur8V -A7qVvdqxevEuUkW4K+2KdMXmnQbG9Aa7k7eBjK1S+0LYmVjPKlJGNXHDGuy5Fw/d -7rjVJ0BLB+ubPK8iA/Tw3hLQgXMRRGRXXCn8ikfuQfjUS1uZSatdLB81mydBETlJ -hI6GH4twrbDJCR2Bwy/XWXgqgGRzAgMBAAECgYBYWVtleUzavkbrPjy0T5FMou8H -X9u2AC2ry8vD/l7cqedtwMPp9k7TubgNFo+NGvKsl2ynyprOZR1xjQ7WgrgVB+mm -uScOM/5HVceFuGRDhYTCObE+y1kxRloNYXnx3ei1zbeYLPCHdhxRYW7T0qcynNmw -rn05/KO2RLjgQNalsQJBANeA3Q4Nugqy4QBUCEC09SqylT2K9FrrItqL2QKc9v0Z -zO2uwllCbg0dwpVuYPYXYvikNHHg+aCWF+VXsb9rpPsCQQDWR9TT4ORdzoj+Nccn -qkMsDmzt0EfNaAOwHOmVJ2RVBspPcxt5iN4HI7HNeG6U5YsFBb+/GZbgfBT3kpNG -WPTpAkBI+gFhjfJvRw38n3g/+UeAkwMI2TJQS4n8+hid0uus3/zOjDySH3XHCUno -cn1xOJAyZODBo47E+67R4jV1/gzbAkEAklJaspRPXP877NssM5nAZMU0/O/NGCZ+ -3jPgDUno6WbJn5cqm8MqWhW1xGkImgRk+fkDBquiq4gPiT898jusgQJAd5Zrr6Q8 -AO/0isr/3aa6O6NLQxISLKcPDk2NOccAfS/xOtfOz4sJYM3+Bs4Io9+dZGSDCA54 -Lw03eHTNQghS0A== ------END PRIVATE KEY----- diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 3b30669..4463fa8 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,5 +1,5 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: be1e2bc21542ae2c00be7784919c1784) *) +(* DO NOT EDIT (digest: e74d46e3c72e3c1e96d59129241f3aad) *) module OASISGettext = struct (* # 21 "src/oasis/OASISGettext.ml" *) @@ -511,12 +511,17 @@ let package_default = [("oauth", ["lib"]); ("oauth_cohttp", ["cohttp"])]; lib_c = []; flags = []; - includes = [("examples/term.ie", ["cohttp"]); ("cohttp", ["lib"])]; + includes = + [ + ("examples/term.ie", ["cohttp"]); + ("examples/localhost", ["cohttp"]); + ("cohttp", ["lib"]) + ]; } ;; let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;; -# 521 "myocamlbuild.ml" +# 526 "myocamlbuild.ml" (* OASIS_STOP *) Ocamlbuild_plugin.dispatch dispatch_default;; diff --git a/setup.ml b/setup.ml index e176dae..3427501 100644 --- a/setup.ml +++ b/setup.ml @@ -1,7 +1,7 @@ (* setup.ml generated for the first time by OASIS v0.3.1 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 20e59aff89ada419f8b47d0534cedb3d) *) +(* DO NOT EDIT (digest: 1ead24be0fedf0ea585a9c8252a30227) *) (* Regenerated by OASIS v0.3.1 Visit http://oasis.forge.ocamlcore.org for more information and @@ -6027,6 +6027,29 @@ let setup_t = bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])]; }, + {exec_custom = false; exec_main_is = "client.ml"; }); + Executable + ({ + cs_name = "client_localhost"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, false)]; + bs_path = "examples/localhost"; + bs_compiled_object = Best; + bs_build_depends = [InternalLibrary "oauth_cohttp"]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, {exec_custom = false; exec_main_is = "client.ml"; }) ]; plugins = @@ -6036,8 +6059,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.3.1"; - oasis_digest = - Some "\226\202\211\251S:\245\157\170\210\202\194\221\215Jn"; + oasis_digest = Some "/\028\183~\187RF\207\t\183FQ@\163\0159"; oasis_exec = None; oasis_setup_args = []; setup_update = false; @@ -6045,6 +6067,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 6049 "setup.ml" +# 6071 "setup.ml" (* OASIS_STOP *) let () = setup ();; From 558a371b5152825c63b3af8eff59b68a730ccc73 Mon Sep 17 00:00:00 2001 From: Vincent Bernardoff Date: Fri, 4 Oct 2013 18:34:26 +0200 Subject: [PATCH 11/14] Use urandom as well when generating keys. --- lib/oauth_util.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/oauth_util.ml b/lib/oauth_util.ml index 4846001..1db27f9 100644 --- a/lib/oauth_util.ml +++ b/lib/oauth_util.ml @@ -1,5 +1,5 @@ open Oauth_common -let make_key ?(rng = Cryptokit.Random.device_rng "/dev/random") () = +let make_key ?(rng = Cryptokit.Random.device_rng "/dev/urandom") () = Cryptokit.Random.string rng 16 |> Cryptokit.transform_string (Oauth_base32.encode ()) From 162f1b5b260c654f5797e80a298ddf4f27f0ccc5 Mon Sep 17 00:00:00 2001 From: Vincent Bernardoff Date: Fri, 4 Oct 2013 18:35:13 +0200 Subject: [PATCH 12/14] localhost server working with (patched) cohttp. --- _oasis | 10 ++- _tags | 21 ++++-- cohttp/oauth_cohttp_http.ml | 7 +- examples/localhost/client.ml | 4 +- examples/localhost/server_cohttp.ml | 67 +++++++++++++++++++ .../localhost/{server.ml => server_netcgi.ml} | 16 ++--- lib/META | 4 +- lib/oauth_client.ml | 2 +- lib/oauth_client.mli | 2 +- lib/oauth_server.ml | 11 +-- lib/oauth_server.mli | 3 +- setup.ml | 33 +++++++-- 12 files changed, 145 insertions(+), 35 deletions(-) create mode 100644 examples/localhost/server_cohttp.ml rename examples/localhost/{server.ml => server_netcgi.ml} (90%) diff --git a/_oasis b/_oasis index fb9be4a..6b1ba9d 100644 --- a/_oasis +++ b/_oasis @@ -23,7 +23,7 @@ Library oauth Path: lib Findlibname: oauth Modules: Oauth_util, Oauth_base32, Oauth_common, Oauth_client, Oauth_server - BuildDepends: cryptokit, uri, re + BuildDepends: cryptokit, uri, re.pcre Library oauth_cohttp Build$: flag(cohttp) @@ -49,3 +49,11 @@ Executable client_localhost CompiledObject: best Build: true Install: false + +Executable server_localhost + Path: examples/localhost + BuildDepends: oauth.cohttp + MainIs: server_cohttp.ml + CompiledObject: best + Build: true + Install: false diff --git a/_tags b/_tags index 45ba401..22022b6 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: 0480a2cf5c45074343ea4267ee9ce003) +# DO NOT EDIT (digest: c7f1bd9cf1aa400dc719cdeeb67ff922) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process @@ -17,38 +17,45 @@ "lib/oauth.cmxs": use_oauth : pkg_cryptokit : pkg_uri -: pkg_re +: pkg_re.pcre # Library oauth_cohttp "cohttp/oauth_cohttp.cmxs": use_oauth_cohttp : use_oauth : pkg_cohttp.lwt : pkg_cryptokit : pkg_uri -: pkg_re +: pkg_re.pcre # Executable client_termie : use_oauth_cohttp : use_oauth : pkg_cohttp.lwt : pkg_cryptokit : pkg_uri -: pkg_re +: pkg_re.pcre : use_oauth_cohttp : use_oauth : pkg_cohttp.lwt : pkg_cryptokit : pkg_uri -: pkg_re +: pkg_re.pcre # Executable client_localhost : use_oauth_cohttp : use_oauth : pkg_cohttp.lwt : pkg_cryptokit : pkg_uri -: pkg_re +: pkg_re.pcre +# Executable server_localhost +: use_oauth_cohttp +: use_oauth +: pkg_cohttp.lwt +: pkg_cryptokit +: pkg_uri +: pkg_re.pcre : use_oauth_cohttp : use_oauth : pkg_cohttp.lwt : pkg_cryptokit : pkg_uri -: pkg_re +: pkg_re.pcre # OASIS_STOP diff --git a/cohttp/oauth_cohttp_http.ml b/cohttp/oauth_cohttp_http.ml index 81decba..58dbb43 100644 --- a/cohttp/oauth_cohttp_http.ml +++ b/cohttp/oauth_cohttp_http.ml @@ -6,17 +6,20 @@ let (>>=) = Lwt.bind module Monad = Lwt -type status = C.Code.status +type status = C.Code.status_code +type meth = C.Code.meth type request = CU.Server.Request.t +exception Error of status * string + let http_method = CU.Request.meth let url req = Uri.to_string (CU.Request.uri req) let header req h = let hs = CU.Request.headers req in - match C.Header.get hs h with + match C.Header.get hs (String.lowercase h) with | Some h -> h | None -> raise Not_found diff --git a/examples/localhost/client.ml b/examples/localhost/client.ml index 7faaf55..c63044c 100644 --- a/examples/localhost/client.ml +++ b/examples/localhost/client.ml @@ -13,7 +13,7 @@ let (>>=) = Lwt.bind let oauth_signature_method = `Hmac_sha1 let http_method = `POST -let url s = "http://localhost:8767" ^ s +let url s = "http://localhost:8787" ^ s let fetch_request_token () = OC.fetch_request_token @@ -58,7 +58,7 @@ let access_resource oauth_token oauth_token_secret = let _ = Lwt_main.run ( fetch_request_token () >>= fun (t, ts) -> - authorize t >>= fun () -> + (* authorize t >>= fun () -> *) fetch_access_token t ts >>= fun (t, ts) -> access_resource t ts ) diff --git a/examples/localhost/server_cohttp.ml b/examples/localhost/server_cohttp.ml new file mode 100644 index 0000000..6361a0f --- /dev/null +++ b/examples/localhost/server_cohttp.ml @@ -0,0 +1,67 @@ +module C = Cohttp +module CU = Cohttp_lwt_unix +module CB = Cohttp_lwt_body + +module Db = +struct + + module Http = Oauth_cohttp_http + + type consumer = string * string + let consumers = ["key", "secret"] + let lookup_consumer k = List.find (fun (k',_) -> k' = k) consumers + let consumer_key (k,_) = k + let consumer_secret (_,s) = s + let consumer_rsa_key _ = raise Not_found + + type request_token = consumer * string * string * bool ref + let request_tokens = ref ([] : request_token list) + let make_request_token c _ = + let t = (c, Oauth_util.make_key (), Oauth_util.make_key (), ref true) in + request_tokens := t::!request_tokens; + t + let lookup_request_token k = List.find (fun (_,k',_,_) -> k' = k) !request_tokens + let request_token_check_consumer (c,_,_,_) c' = c = c' + let request_token_token (_,k,_,_) = k + let request_token_secret (_,_,s,_) = s + let request_token_authorized (_,_,_,a) = !a + let authorize_request_token (_,_,_,a) _ = a := true + + type access_token = consumer * string * string + let access_tokens = ref [] + let exchange_request_token ((c,k,s,a) as rt) = + if not !a + then raise (Failure "access token not authorized"); + request_tokens := List.filter (fun rt' -> rt' <> rt) !request_tokens; + let t = (c, Oauth_util.make_key (), Oauth_util.make_key ()) in + access_tokens := t::!access_tokens; + t + let lookup_access_token k = List.find (fun (_,k',_) -> k' = k) !access_tokens + let access_token_check_consumer (c,_,_) c' = c = c' + let access_token_token (_,k,_) = k + let access_token_secret (_,_,s) = s + +end + +module OS = Oauth_server.Make(Oauth_cohttp_http)(Db) + +let echo tok tok_secret req = + CU.Server.respond_string ~status:`OK ~body:"Bleh!" () + +let oauth_callback conn_id ?body request = + let open CU.Server in + let uri = Request.uri request in + let path = Uri.path uri in + match path with + | "/request_token" -> OS.fetch_request_token request + | "/access_token" -> OS.fetch_access_token request + | "/echo" -> OS.access_resource request echo + | _ -> CU.Server.respond_not_found () + +let config = CU.Server.({ + callback=oauth_callback; + conn_closed = (fun id () -> ()) +}) + +let _ = Lwt_main.run + (CU.Server.create ~address:"localhost" ~port:8787 config) diff --git a/examples/localhost/server.ml b/examples/localhost/server_netcgi.ml similarity index 90% rename from examples/localhost/server.ml rename to examples/localhost/server_netcgi.ml index ea4beeb..0b750c8 100644 --- a/examples/localhost/server.ml +++ b/examples/localhost/server_netcgi.ml @@ -1,14 +1,14 @@ module Db = struct - module Http = Oauth_netcgi_http + module Http = Oauth_cohttp_http - type consumer = string * string * Cryptokit.RSA.key - let consumers = ["key", "secret", Rsa.read_rsa_pubkey "public_key.pem" ] - let lookup_consumer k = List.find (fun (k',_,_) -> k' = k) consumers - let consumer_key (k,_,_) = k - let consumer_secret (_,s,_) = s - let consumer_rsa_key (_,_,r) = r + type consumer = string * string + let consumers = ["key", "secret"] + let lookup_consumer k = List.find (fun (k',_) -> k' = k) consumers + let consumer_key (k,_) = k + let consumer_secret (_,s) = s + let consumer_rsa_key _ = raise Not_found type request_token = consumer * string * string * bool ref let request_tokens = ref ([] : request_token list) @@ -39,7 +39,7 @@ struct end -module OS = Oauth_server.Make(Oauth_netcgi_http)(Db) +module OS = Oauth_server.Make(Oauth_cohttp_http)(Db) let authorize_get oauth_token request_token (cgi : Netcgi.cgi_activation) = Oauth_netcgi_http.respond cgi `Ok [] diff --git a/lib/META b/lib/META index d4cba5f..7804351 100644 --- a/lib/META +++ b/lib/META @@ -1,8 +1,8 @@ # OASIS_START -# DO NOT EDIT (digest: 3478246be9a44fd86570d1b1d4b9ad48) +# DO NOT EDIT (digest: 1ad4d3f9da143068eff811b95a138630) version = "0.1" description = "OAuth for OCaml" -requires = "cryptokit uri re" +requires = "cryptokit uri re.pcre" archive(byte) = "oauth.cma" archive(byte, plugin) = "oauth.cma" archive(native) = "oauth.cmxa" diff --git a/lib/oauth_client.ml b/lib/oauth_client.ml index 889fec7..2635722 100644 --- a/lib/oauth_client.ml +++ b/lib/oauth_client.ml @@ -52,7 +52,7 @@ sig | `Unsupported_media_type | `Use_proxy ] - type meth = [ `DELETE | `GET | `HEAD | `PATCH | `POST | `PUT ] + type meth = [ `DELETE | `GET | `HEAD | `OPTIONS | `PATCH | `POST | `PUT ] val request : ?http_method:meth -> diff --git a/lib/oauth_client.mli b/lib/oauth_client.mli index b221438..c609b5c 100644 --- a/lib/oauth_client.mli +++ b/lib/oauth_client.mli @@ -52,7 +52,7 @@ sig | `Unsupported_media_type | `Use_proxy ] - type meth = [ `DELETE | `GET | `HEAD | `PATCH | `POST | `PUT ] + type meth = [ `DELETE | `GET | `HEAD | `OPTIONS | `PATCH | `POST | `PUT ] val request : ?http_method:meth -> diff --git a/lib/oauth_server.ml b/lib/oauth_server.ml index e67f3ec..1457133 100644 --- a/lib/oauth_server.ml +++ b/lib/oauth_server.ml @@ -12,6 +12,7 @@ sig [ `Accepted | `Bad_gateway | `Bad_request + | `Code of int | `Conflict | `Continue | `Created @@ -109,16 +110,16 @@ struct let args = List.map (fun p -> - match Re_pcre.(extract ~rex:(regexp "(\\S*)\\s*=\\s*\"([^\"]*)\"") p) with - | [| _; k; v |] -> k, Oauth_common.rfc3986_decode v - | _ -> raise Not_found) (* bad header, fall back to CGI args (?) *) + match Re_pcre.(extract ~rex:(regexp "(\\S*)\\s*=\\s*\"([^\"]*)\"") p) with + | [| _; k; v |] -> k, Oauth_common.rfc3986_decode v + | _ -> raise Not_found) (* bad header, fall back to CGI args (?) *) parts in let arg ?default name = try List.assoc name args with Not_found as e -> match default with - | Some d -> d - | _ -> raise e in + | Some d -> d + | _ -> raise e in arg with Not_found -> Http.argument req in diff --git a/lib/oauth_server.mli b/lib/oauth_server.mli index e01ae0b..d42fc02 100644 --- a/lib/oauth_server.mli +++ b/lib/oauth_server.mli @@ -8,10 +8,11 @@ sig val (>|=) : 'a t -> ('a -> 'b) -> 'b t end - type status = +type status = [ `Accepted | `Bad_gateway | `Bad_request + | `Code of int | `Conflict | `Continue | `Created diff --git a/setup.ml b/setup.ml index 3427501..f2267c8 100644 --- a/setup.ml +++ b/setup.ml @@ -1,7 +1,7 @@ (* setup.ml generated for the first time by OASIS v0.3.1 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 1ead24be0fedf0ea585a9c8252a30227) *) +(* DO NOT EDIT (digest: 3ee3e4268e743c6f5c18a039bb0ae333) *) (* Regenerated by OASIS v0.3.1 Visit http://oasis.forge.ocamlcore.org for more information and @@ -5935,7 +5935,7 @@ let setup_t = [ FindlibPackage ("cryptokit", None); FindlibPackage ("uri", None); - FindlibPackage ("re", None) + FindlibPackage ("re.pcre", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; @@ -6050,7 +6050,30 @@ let setup_t = bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])]; }, - {exec_custom = false; exec_main_is = "client.ml"; }) + {exec_custom = false; exec_main_is = "client.ml"; }); + Executable + ({ + cs_name = "server_localhost"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, false)]; + bs_path = "examples/localhost"; + bs_compiled_object = Best; + bs_build_depends = [InternalLibrary "oauth_cohttp"]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + {exec_custom = false; exec_main_is = "server_cohttp.ml"; }) ]; plugins = [(`Extra, "META", Some "0.3"); (`Extra, "DevFiles", Some "0.3")]; @@ -6059,7 +6082,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.3.1"; - oasis_digest = Some "/\028\183~\187RF\207\t\183FQ@\163\0159"; + oasis_digest = Some "\210n\198\137 \016\232\021\028-%;.\193\199\230"; oasis_exec = None; oasis_setup_args = []; setup_update = false; @@ -6067,6 +6090,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 6071 "setup.ml" +# 6094 "setup.ml" (* OASIS_STOP *) let () = setup ();; From 231dadd636126d908452d06c5297547237e52b8e Mon Sep 17 00:00:00 2001 From: Vincent Bernardoff Date: Thu, 10 Oct 2013 20:03:37 +0200 Subject: [PATCH 13/14] Changed some vocabulary to be in sync with the revised OAuth spec. --- examples/localhost/client.ml | 20 +++-- examples/localhost/server_cohttp.ml | 72 ++++++++------- examples/term.ie/client.ml | 28 +++--- lib/oauth_client.ml | 26 +++--- lib/oauth_client.mli | 16 ++-- lib/oauth_common.ml | 18 ++-- lib/oauth_server.ml | 131 +++++++++++++++------------- lib/oauth_server.mli | 61 +++++++------ 8 files changed, 197 insertions(+), 175 deletions(-) diff --git a/examples/localhost/client.ml b/examples/localhost/client.ml index c63044c..8e03582 100644 --- a/examples/localhost/client.ml +++ b/examples/localhost/client.ml @@ -10,16 +10,18 @@ module OC = Oauth_client.Make(Oauth_cohttp_http_client) let (>>=) = Lwt.bind +let oauth_client = "key" +let oauth_client_secret = "secret" let oauth_signature_method = `Hmac_sha1 let http_method = `POST let url s = "http://localhost:8787" ^ s -let fetch_request_token () = - OC.fetch_request_token +let fetch_temporary_credentials () = + OC.fetch_temporary_credentials ~http_method ~url:(url "/request_token") ~oauth_signature_method - ~oauth_consumer_key:"key" ~oauth_consumer_secret:"secret" + ~oauth_client ~oauth_client_secret () >>= fun (oauth_token, oauth_token_secret) -> prerr_endline ("oauth_token = " ^ oauth_token); @@ -33,11 +35,11 @@ let authorize oauth_token = ~params:["oauth_token", oauth_token] () >>= fun _ -> Lwt.return () -let fetch_access_token oauth_token oauth_token_secret = - OC.fetch_access_token +let fetch_token_credentials oauth_token oauth_token_secret = + OC.fetch_token_credentials ~http_method ~url:(url "/access_token") ~oauth_signature_method - ~oauth_consumer_key:"key" ~oauth_consumer_secret:"secret" + ~oauth_client ~oauth_client_secret ~oauth_token ~oauth_token_secret () >>= fun (oauth_token, oauth_token_secret) -> @@ -49,7 +51,7 @@ let access_resource oauth_token oauth_token_secret = OC.access_resource ~http_method ~url:(url "/echo") ~oauth_signature_method - ~oauth_consumer_key:"key" ~oauth_consumer_secret:"secret" + ~oauth_client ~oauth_client_secret ~oauth_token ~oauth_token_secret ~params:["method", "foo"; "bar", "baz"] () >>= fun res -> @@ -57,8 +59,8 @@ let access_resource oauth_token oauth_token_secret = let _ = Lwt_main.run ( - fetch_request_token () >>= fun (t, ts) -> + fetch_temporary_credentials () >>= fun (t, ts) -> (* authorize t >>= fun () -> *) - fetch_access_token t ts >>= fun (t, ts) -> + fetch_token_credentials t ts >>= fun (t, ts) -> access_resource t ts ) diff --git a/examples/localhost/server_cohttp.ml b/examples/localhost/server_cohttp.ml index 6361a0f..a6b4362 100644 --- a/examples/localhost/server_cohttp.ml +++ b/examples/localhost/server_cohttp.ml @@ -7,39 +7,45 @@ struct module Http = Oauth_cohttp_http - type consumer = string * string - let consumers = ["key", "secret"] - let lookup_consumer k = List.find (fun (k',_) -> k' = k) consumers - let consumer_key (k,_) = k - let consumer_secret (_,s) = s - let consumer_rsa_key _ = raise Not_found + module Client = struct + type t = string * string + let clients = ["key", "secret"] + let find k = List.find (fun (k',_) -> k' = k) clients + let id (k,_) = k + let secret (_,s) = s + let rsa_key _ = raise Not_found + end - type request_token = consumer * string * string * bool ref - let request_tokens = ref ([] : request_token list) - let make_request_token c _ = - let t = (c, Oauth_util.make_key (), Oauth_util.make_key (), ref true) in - request_tokens := t::!request_tokens; - t - let lookup_request_token k = List.find (fun (_,k',_,_) -> k' = k) !request_tokens - let request_token_check_consumer (c,_,_,_) c' = c = c' - let request_token_token (_,k,_,_) = k - let request_token_secret (_,_,s,_) = s - let request_token_authorized (_,_,_,a) = !a - let authorize_request_token (_,_,_,a) _ = a := true + module Temporary = struct + type t = Client.t * string * string * bool ref + let temporary_credentials = ref ([] : t list) + let make c _ = + let t = (c, Oauth_util.make_key (), Oauth_util.make_key (), ref true) in + temporary_credentials := t::!temporary_credentials; + t + let find k = List.find (fun (_,k',_,_) -> k' = k) !temporary_credentials + let check_client (c,_,_,_) c' = c = c' + let key (_,k,_,_) = k + let secret (_,_,s,_) = s + let authorized (_,_,_,a) = !a + let authorize (_,_,_,a) _ = a := true + end - type access_token = consumer * string * string - let access_tokens = ref [] - let exchange_request_token ((c,k,s,a) as rt) = - if not !a - then raise (Failure "access token not authorized"); - request_tokens := List.filter (fun rt' -> rt' <> rt) !request_tokens; - let t = (c, Oauth_util.make_key (), Oauth_util.make_key ()) in - access_tokens := t::!access_tokens; - t - let lookup_access_token k = List.find (fun (_,k',_) -> k' = k) !access_tokens - let access_token_check_consumer (c,_,_) c' = c = c' - let access_token_token (_,k,_) = k - let access_token_secret (_,_,s) = s + module Token = struct + type t = Client.t * string * string + let token_credentials = ref [] + let exchange_temporary ((c,k,s,a) as rt) = + if not !a + then raise (Failure "access token not authorized"); + Temporary.(temporary_credentials := List.filter (fun rt' -> rt' <> rt) !temporary_credentials); + let t = (c, Oauth_util.make_key (), Oauth_util.make_key ()) in + token_credentials := t::!token_credentials; + t + let find k = List.find (fun (_,k',_) -> k' = k) !token_credentials + let check_client (c,_,_) c' = c = c' + let key (_,k,_) = k + let secret (_,_,s) = s + end end @@ -53,8 +59,8 @@ let oauth_callback conn_id ?body request = let uri = Request.uri request in let path = Uri.path uri in match path with - | "/request_token" -> OS.fetch_request_token request - | "/access_token" -> OS.fetch_access_token request + | "/request_token" -> OS.fetch_temporary_credentials request + | "/access_token" -> OS.fetch_token_credentials request | "/echo" -> OS.access_resource request echo | _ -> CU.Server.respond_not_found () diff --git a/examples/term.ie/client.ml b/examples/term.ie/client.ml index 676e299..c639f41 100644 --- a/examples/term.ie/client.ml +++ b/examples/term.ie/client.ml @@ -5,32 +5,32 @@ module OC = Oauth_client.Make(Oauth_cohttp_http_client) let (>>=) = Lwt.bind (* from http://term.ie/oauth/example *) -let oauth_consumer_key = "key" -let oauth_consumer_secret = "secret" +let oauth_client = "key" +let oauth_client_secret = "secret" let oauth_signature_method = `Hmac_sha1 let http_method = `POST let url s = "http://term.ie/oauth/example" ^ s -let fetch_request_token () = - OC.fetch_request_token +let fetch_temporary_credentials () = + OC.fetch_temporary_credentials ~http_method ~url:(url "/request_token.php") ~oauth_signature_method - ~oauth_consumer_key - ~oauth_consumer_secret + ~oauth_client + ~oauth_client_secret () >>= fun (oauth_token, oauth_token_secret) -> prerr_endline ("oauth_token = " ^ oauth_token); prerr_endline ("oauth_token_secret = " ^ oauth_token_secret); Lwt.return (oauth_token, oauth_token_secret) -let fetch_access_token oauth_token oauth_token_secret = - OC.fetch_access_token +let fetch_token_credentials oauth_token oauth_token_secret = + OC.fetch_token_credentials ~http_method ~url:(url "/access_token.php") ~oauth_signature_method - ~oauth_consumer_key - ~oauth_consumer_secret + ~oauth_client + ~oauth_client_secret ~oauth_token ~oauth_token_secret () >>= fun (oauth_token, oauth_token_secret) -> @@ -42,8 +42,8 @@ let access_resource oauth_token oauth_token_secret = OC.access_resource ~http_method ~url:(url "/echo_api.php") ~oauth_signature_method - ~oauth_consumer_key - ~oauth_consumer_secret + ~oauth_client + ~oauth_client_secret ~oauth_token ~oauth_token_secret ~params:["method", "foo"; "bar", "baz"] @@ -51,6 +51,6 @@ let access_resource oauth_token oauth_token_secret = Lwt_io.eprintl ("res = " ^ res) let _ = Lwt_main.run - (fetch_request_token () >>= fun (t, st) -> - fetch_access_token t st >>= fun (t, st) -> + (fetch_temporary_credentials () >>= fun (t, st) -> + fetch_token_credentials t st >>= fun (t, st) -> access_resource t st) diff --git a/lib/oauth_client.ml b/lib/oauth_client.ml index 2635722..6d46038 100644 --- a/lib/oauth_client.ml +++ b/lib/oauth_client.ml @@ -77,7 +77,7 @@ struct let authorization_header ~oauth_version ~oauth_signature_method ~oauth_signature - ~oauth_consumer_key ?oauth_token + ~oauth_client ?oauth_token ~oauth_timestamp ~oauth_nonce () = let params = @@ -86,7 +86,7 @@ struct "oauth_version", oauth_version; "oauth_signature_method", string_of_signature_method oauth_signature_method; "oauth_signature", oauth_signature; - "oauth_consumer_key", oauth_consumer_key; + "oauth_consumer_key", oauth_client; "oauth_timestamp", string_of_timestamp oauth_timestamp; "oauth_nonce", oauth_nonce; ] @ @@ -108,10 +108,10 @@ struct - let fetch_request_token + let fetch_temporary_credentials ?(http_method = `POST) ~url ?(oauth_version = "1.0") ?(oauth_signature_method = `Hmac_sha1) - ~oauth_consumer_key ~oauth_consumer_secret + ~oauth_client ~oauth_client_secret ?(oauth_timestamp = make_timestamp ()) ?(oauth_nonce = make_nonce ()) ?params ?(headers = []) () = @@ -120,7 +120,7 @@ struct sign ~http_method ~url ~oauth_version ~oauth_signature_method - ~oauth_consumer_key ~oauth_consumer_secret + ~oauth_client ~oauth_client_secret ~oauth_timestamp ~oauth_nonce ?params () in @@ -128,7 +128,7 @@ struct let headers = authorization_header ~oauth_version ~oauth_signature_method ~oauth_signature - ~oauth_consumer_key + ~oauth_client ~oauth_timestamp ~oauth_nonce () :: headers in @@ -143,10 +143,10 @@ struct - let fetch_access_token + let fetch_token_credentials ?(http_method = `POST) ~url ?(oauth_version = "1.0") ?(oauth_signature_method = `Hmac_sha1) - ~oauth_consumer_key ~oauth_consumer_secret + ~oauth_client ~oauth_client_secret ~oauth_token ~oauth_token_secret ?(oauth_timestamp = make_timestamp ()) ?(oauth_nonce = make_nonce ()) ?(headers = []) @@ -156,7 +156,7 @@ struct sign ~http_method ~url ~oauth_version ~oauth_signature_method - ~oauth_consumer_key ~oauth_consumer_secret + ~oauth_client ~oauth_client_secret ~oauth_token ~oauth_token_secret ~oauth_timestamp ~oauth_nonce () in @@ -164,7 +164,7 @@ struct let headers = authorization_header ~oauth_version ~oauth_signature_method ~oauth_signature - ~oauth_consumer_key ~oauth_token + ~oauth_client ~oauth_token ~oauth_timestamp ~oauth_nonce () :: headers in @@ -181,7 +181,7 @@ struct let access_resource ?(http_method = `POST) ~url ?(oauth_version = "1.0") ?(oauth_signature_method = `Hmac_sha1) - ~oauth_consumer_key ~oauth_consumer_secret + ~oauth_client ~oauth_client_secret ~oauth_token ~oauth_token_secret ?(oauth_timestamp = make_timestamp ()) ?(oauth_nonce = make_nonce ()) ?params ?(headers = []) ?body @@ -191,7 +191,7 @@ struct sign ~http_method ~url ~oauth_version ~oauth_signature_method - ~oauth_consumer_key ~oauth_consumer_secret + ~oauth_client ~oauth_client_secret ~oauth_token ~oauth_token_secret ~oauth_timestamp ~oauth_nonce ?params @@ -200,7 +200,7 @@ struct let headers = authorization_header ~oauth_version ~oauth_signature_method ~oauth_signature - ~oauth_consumer_key ~oauth_token + ~oauth_client ~oauth_token ~oauth_timestamp ~oauth_nonce () :: headers in diff --git a/lib/oauth_client.mli b/lib/oauth_client.mli index c609b5c..d389bd8 100644 --- a/lib/oauth_client.mli +++ b/lib/oauth_client.mli @@ -69,13 +69,13 @@ sig exception Error of Http_client.status * string - val fetch_request_token : + val fetch_temporary_credentials : ?http_method:Http_client.meth -> url:string -> ?oauth_version:string -> ?oauth_signature_method:[ `Plaintext | `Hmac_sha1 | `Rsa_sha1 of Cryptokit.RSA.key ] -> - oauth_consumer_key:string -> - oauth_consumer_secret:string -> + oauth_client:string -> + oauth_client_secret:string -> ?oauth_timestamp:float -> ?oauth_nonce:string -> ?params:(string * string) list -> @@ -83,13 +83,13 @@ sig unit -> (string * string) Http_client.Monad.t - val fetch_access_token : + val fetch_token_credentials : ?http_method:Http_client.meth -> url:string -> ?oauth_version:string -> ?oauth_signature_method:[ `Plaintext | `Hmac_sha1 | `Rsa_sha1 of Cryptokit.RSA.key ] -> - oauth_consumer_key:string -> - oauth_consumer_secret:string -> + oauth_client:string -> + oauth_client_secret:string -> oauth_token:string -> oauth_token_secret:string -> ?oauth_timestamp:float -> @@ -103,8 +103,8 @@ sig url:string -> ?oauth_version:string -> ?oauth_signature_method:[ `Plaintext | `Hmac_sha1 | `Rsa_sha1 of Cryptokit.RSA.key ] -> - oauth_consumer_key:string -> - oauth_consumer_secret:string -> + oauth_client:string -> + oauth_client_secret:string -> oauth_token:string -> oauth_token_secret:string -> ?oauth_timestamp:float -> diff --git a/lib/oauth_common.ml b/lib/oauth_common.ml index 2995bda..d870f6b 100644 --- a/lib/oauth_common.ml +++ b/lib/oauth_common.ml @@ -88,7 +88,7 @@ let check_rsa_sha1_hash text rsa_key signature = let signature_base_string ~http_method ~url ~oauth_signature_method - ~oauth_consumer_key ~oauth_consumer_secret + ~oauth_client ~oauth_client_secret ?oauth_token ?oauth_token_secret ~oauth_timestamp ~oauth_nonce ~oauth_version ?(params = []) @@ -96,10 +96,10 @@ let signature_base_string let params = [ "oauth_signature_method", string_of_signature_method oauth_signature_method; - "oauth_consumer_key", oauth_consumer_key; + "oauth_consumer_key", oauth_client; "oauth_timestamp", string_of_timestamp oauth_timestamp; "oauth_nonce", oauth_nonce; - "oauth_version", oauth_version; + "oauth_version", oauth_version; ] @ opt_param "oauth_token" oauth_token @ List.filter (fun (k, v) -> k <> "oauth_signature") params in @@ -124,14 +124,14 @@ let signature_base_string let sign ~http_method ~url ~oauth_signature_method - ~oauth_consumer_key ~oauth_consumer_secret + ~oauth_client ~oauth_client_secret ?oauth_token ?oauth_token_secret ~oauth_timestamp ~oauth_nonce ~oauth_version ?params () = let key = - (rfc3986_encode oauth_consumer_secret ^ "&" ^ + (rfc3986_encode oauth_client_secret ^ "&" ^ match oauth_token_secret with | None -> "" | Some s -> rfc3986_encode s) in @@ -140,7 +140,7 @@ let sign signature_base_string ~http_method ~url ~oauth_signature_method - ~oauth_consumer_key ~oauth_consumer_secret + ~oauth_client ~oauth_client_secret ?oauth_token ?oauth_token_secret ~oauth_timestamp ~oauth_nonce ~oauth_version ?params @@ -156,14 +156,14 @@ let sign let check_signature ~http_method ~url ~oauth_signature_method ~oauth_signature - ~oauth_consumer_key ~oauth_consumer_secret + ~oauth_client ~oauth_client_secret ?oauth_token ?oauth_token_secret ~oauth_timestamp ~oauth_nonce ~oauth_version ?params () = let key = - (rfc3986_encode oauth_consumer_secret ^ "&" ^ + (rfc3986_encode oauth_client_secret ^ "&" ^ match oauth_token_secret with | None -> "" | Some s -> rfc3986_encode s) in @@ -172,7 +172,7 @@ let check_signature signature_base_string ~http_method ~url ~oauth_signature_method - ~oauth_consumer_key ~oauth_consumer_secret + ~oauth_client ~oauth_client_secret ?oauth_token ?oauth_token_secret ~oauth_timestamp ~oauth_nonce ~oauth_version ?params diff --git a/lib/oauth_server.ml b/lib/oauth_server.ml index 1457133..71a1be1 100644 --- a/lib/oauth_server.ml +++ b/lib/oauth_server.ml @@ -67,36 +67,43 @@ sig exception Error of status * string end -module type Db = +module type DB = sig module Http : Http - type consumer - val lookup_consumer : string -> consumer (* throws Not_found *) - val consumer_key : consumer -> string - val consumer_secret : consumer -> string - val consumer_rsa_key : consumer -> Cryptokit.RSA.key (* throws Not_found *) - - type request_token - val make_request_token : consumer -> Http.request -> request_token - val lookup_request_token: string -> request_token (* throws Not_found *) - val request_token_check_consumer : request_token -> consumer -> bool - val request_token_token : request_token -> string - val request_token_secret : request_token -> string - val request_token_authorized : request_token -> bool - val authorize_request_token : request_token -> Http.request -> unit (* throws Failure *) - - type access_token - val exchange_request_token : request_token -> access_token (* throws Failure *) - val lookup_access_token : string -> access_token (* throws Not_found *) - val access_token_check_consumer : access_token -> consumer -> bool - val access_token_token : access_token -> string - val access_token_secret : access_token -> string + module Client : sig + type t + val find : string -> t (* throws Not_found *) + val id : t -> string + val secret : t -> string + val rsa_key : t -> Cryptokit.RSA.key (* throws Not_found *) + end + + module Temporary : sig + type t + val temporary_credentials : t list ref + val make : Client.t -> Http.request -> t + val find : string -> t (* throws Not_found *) + val check_client : t -> Client.t -> bool + val key : t -> string + val secret : t -> string + val authorized : t -> bool + val authorize : t -> Http.request -> unit (* throws Failure *) + end + + module Token : sig + type t + val exchange_temporary : Temporary.t -> t (* throws Failure *) + val find : string -> t (* throws Not_found *) + val check_client : t -> Client.t -> bool + val key : t -> string + val secret : t -> string + end end module Make (Http : Http) - (Db : Db with module Http = Http) = + (Db : DB with module Http = Http) = struct let bad_request msg = raise (Http.Error (`Bad_request, msg)) @@ -133,7 +140,7 @@ struct let http_method = Http.http_method req in let url = Http.url req in - let oauth_consumer_key = required_arg "oauth_consumer_key" in + let oauth_client = required_arg "oauth_consumer_key" in let oauth_token = optional_arg "oauth_token" in let oauth_signature_method = required_arg "oauth_signature_method" in let oauth_signature = required_arg "oauth_signature" in @@ -143,15 +150,15 @@ struct if oauth_version <> "1.0" then bad_request ("unsupported version " ^ oauth_version); - let consumer = - try Db.lookup_consumer oauth_consumer_key - with Not_found -> unauthorized "invalid consumer key" in - let oauth_consumer_secret = Db.consumer_secret consumer in + let client_credentials = + try Db.Client.find oauth_client + with Not_found -> unauthorized "invalid client" in + let oauth_client_secret = Db.Client.secret client_credentials in let oauth_signature_method = try Oauth_common.signature_method_of_string (fun () -> - try Db.consumer_rsa_key consumer + try Db.Client.rsa_key client_credentials with Not_found -> unauthorized "no RSA key") oauth_signature_method with Not_found -> @@ -161,8 +168,8 @@ struct with Failure _ -> 0. in f - ~http_method ~url ~consumer - ~oauth_consumer_key ~oauth_consumer_secret + ~http_method ~url ~client_credentials + ~oauth_client ~oauth_client_secret ~oauth_signature_method ~oauth_signature ~oauth_timestamp ~oauth_nonce ~oauth_version ?oauth_token @@ -170,10 +177,10 @@ struct - let fetch_request_token req = + let fetch_temporary_credentials req = let frt - ~http_method ~url ~consumer - ~oauth_consumer_key ~oauth_consumer_secret + ~http_method ~url ~client_credentials + ~oauth_client ~oauth_client_secret ~oauth_signature_method ~oauth_signature ~oauth_timestamp ~oauth_nonce ~oauth_version ?oauth_token @@ -182,16 +189,16 @@ struct Oauth_common.check_signature ~http_method ~url ~oauth_signature_method ~oauth_signature - ~oauth_consumer_key ~oauth_consumer_secret + ~oauth_client ~oauth_client_secret ~oauth_timestamp ~oauth_nonce ~oauth_version ~params:(Http.arguments req) () then - let request_token = Db.make_request_token consumer req in + let request_token = Db.Temporary.make client_credentials req in Http.respond req `OK [] (Uri.encoded_of_query [ - "oauth_token", [Db.request_token_token request_token]; - "oauth_token_secret", [Db.request_token_secret request_token]; + "oauth_token", [Db.Temporary.key request_token]; + "oauth_token_secret", [Db.Temporary.secret request_token]; ]) else unauthorized "invalid signature" in @@ -200,10 +207,10 @@ struct - let fetch_access_token req = + let fetch_token_credentials req = let frt - ~http_method ~url ~consumer - ~oauth_consumer_key ~oauth_consumer_secret + ~http_method ~url ~client_credentials + ~oauth_client ~oauth_client_secret ~oauth_signature_method ~oauth_signature ~oauth_timestamp ~oauth_nonce ~oauth_version ?oauth_token @@ -212,29 +219,29 @@ struct match oauth_token with | None -> bad_request "missing parameter oauth_token" | Some t -> - try Db.lookup_request_token t + try Db.Temporary.find t with Not_found -> unauthorized "invalid request token" in - if not (Db.request_token_check_consumer request_token consumer) - then bad_request "consumer/request token mismatch"; - let oauth_token = Db.request_token_token request_token in - let oauth_token_secret = Db.request_token_secret request_token in + if not (Db.Temporary.check_client request_token client_credentials) + then bad_request "client/temporary token mismatch"; + let oauth_token = Db.Temporary.key request_token in + let oauth_token_secret = Db.Temporary.secret request_token in if Oauth_common.check_signature ~http_method ~url ~oauth_signature_method ~oauth_signature - ~oauth_consumer_key ~oauth_consumer_secret + ~oauth_client ~oauth_client_secret ~oauth_token ~oauth_token_secret ~oauth_timestamp ~oauth_nonce ~oauth_version ~params:(Http.arguments req) () then let access_token = - try Db.exchange_request_token request_token + try Db.Token.exchange_temporary request_token with Failure msg -> unauthorized msg in Http.respond req `OK [] (Uri.encoded_of_query [ - "oauth_token", [Db.access_token_token access_token]; - "oauth_token_secret", [Db.access_token_secret access_token]; + "oauth_token", [Db.Token.key access_token]; + "oauth_token_secret", [Db.Token.secret access_token]; ]) else unauthorized "invalid signature" in @@ -243,22 +250,22 @@ struct - let authorize_request_token req kget kpost = + let authorize_temporary_credentials req kget kpost = try let oauth_token = try Http.argument req "oauth_token" with Not_found -> bad_request "missing parameter oauth_token" in let request_token = - try Db.lookup_request_token oauth_token + try Db.Temporary.find oauth_token with Not_found -> unauthorized "invalid request token" in - if Db.request_token_authorized request_token + if Db.Temporary.authorized request_token then bad_request "request token already authorized"; match Http.http_method req with | `GET -> kget oauth_token request_token req | `POST -> - Db.authorize_request_token request_token req; + Db.Temporary.authorize request_token req; kpost oauth_token request_token req | _ -> raise (Http.Error (`Method_not_allowed, "")) @@ -268,8 +275,8 @@ struct let access_resource req k = let frt - ~http_method ~url ~consumer - ~oauth_consumer_key ~oauth_consumer_secret + ~http_method ~url ~client_credentials + ~oauth_client ~oauth_client_secret ~oauth_signature_method ~oauth_signature ~oauth_timestamp ~oauth_nonce ~oauth_version ?oauth_token @@ -278,17 +285,17 @@ struct match oauth_token with | None -> bad_request "missing parameter oauth_token" | Some t -> - try Db.lookup_access_token t + try Db.Token.find t with Not_found -> unauthorized "invalid access token" in - if not (Db.access_token_check_consumer access_token consumer) - then bad_request "consumer/access token mismatch"; - let oauth_token = Db.access_token_token access_token in - let oauth_token_secret = Db.access_token_secret access_token in + if not (Db.Token.check_client access_token client_credentials) + then bad_request "client/token mismatch"; + let oauth_token = Db.Token.key access_token in + let oauth_token_secret = Db.Token.secret access_token in if Oauth_common.check_signature ~http_method ~url ~oauth_signature_method ~oauth_signature - ~oauth_consumer_key ~oauth_consumer_secret + ~oauth_client ~oauth_client_secret ~oauth_token ~oauth_token_secret ~oauth_timestamp ~oauth_nonce ~oauth_version ~params:(Http.arguments req) diff --git a/lib/oauth_server.mli b/lib/oauth_server.mli index d42fc02..bbd255c 100644 --- a/lib/oauth_server.mli +++ b/lib/oauth_server.mli @@ -67,49 +67,56 @@ type status = exception Error of status * string end -module type Db = +module type DB = sig module Http : Http - type consumer - val lookup_consumer : string -> consumer (* throws Not_found *) - val consumer_key : consumer -> string - val consumer_secret : consumer -> string - val consumer_rsa_key : consumer -> Cryptokit.RSA.key (* throws Not_found *) + module Client : sig + type t + val find : string -> t (* throws Not_found *) + val id : t -> string + val secret : t -> string + val rsa_key : t -> Cryptokit.RSA.key (* throws Not_found *) + end - type request_token - val make_request_token : consumer -> Http.request -> request_token - val lookup_request_token: string -> request_token (* throws Not_found *) - val request_token_check_consumer : request_token -> consumer -> bool - val request_token_token : request_token -> string - val request_token_secret : request_token -> string - val request_token_authorized : request_token -> bool - val authorize_request_token : request_token -> Http.request -> unit (* throws Failure *) + module Temporary : sig + type t + val temporary_credentials : t list ref + val make : Client.t -> Http.request -> t + val find : string -> t (* throws Not_found *) + val check_client : t -> Client.t -> bool + val key : t -> string + val secret : t -> string + val authorized : t -> bool + val authorize : t -> Http.request -> unit (* throws Failure *) + end - type access_token - val exchange_request_token : request_token -> access_token (* throws Failure *) - val lookup_access_token : string -> access_token (* throws Not_found *) - val access_token_check_consumer : access_token -> consumer -> bool - val access_token_token : access_token -> string - val access_token_secret : access_token -> string + module Token : sig + type t + val exchange_temporary : Temporary.t -> t (* throws Failure *) + val find : string -> t (* throws Not_found *) + val check_client : t -> Client.t -> bool + val key : t -> string + val secret : t -> string + end end -module Make (Http : Http) (Db : Db with module Http = Http) : +module Make (Http : Http) (Db : DB with module Http = Http) : sig - val fetch_request_token : Http.request -> Http.response Http.Monad.t + val fetch_temporary_credentials : Http.request -> Http.response Http.Monad.t - val fetch_access_token : Http.request -> Http.response Http.Monad.t + val fetch_token_credentials : Http.request -> Http.response Http.Monad.t - val authorize_request_token : + val authorize_temporary_credentials : Http.request -> - (string -> Db.request_token -> Http.request -> Http.response Http.Monad.t) -> - (string -> Db.request_token -> Http.request -> Http.response Http.Monad.t) -> + (string -> Db.Temporary.t -> Http.request -> Http.response Http.Monad.t) -> + (string -> Db.Temporary.t -> Http.request -> Http.response Http.Monad.t) -> Http.response Http.Monad.t val access_resource : Http.request -> - (string -> Db.access_token -> Http.request -> Http.response Http.Monad.t) -> + (string -> Db.Token.t -> Http.request -> Http.response Http.Monad.t) -> Http.response Http.Monad.t end From 084ee322717609e17307502f6d5debfa4df5d326 Mon Sep 17 00:00:00 2001 From: Vincent Bernardoff Date: Mon, 27 Jan 2014 16:00:10 +0100 Subject: [PATCH 14/14] Replaced status by status_code in functor. --- cohttp/oauth_cohttp_http.ml | 5 ++- cohttp/oauth_cohttp_http_client.ml | 4 +- lib/oauth_client.ml | 59 ++++-------------------------- lib/oauth_client.mli | 51 ++------------------------ lib/oauth_server.ml | 58 ++++------------------------- lib/oauth_server.mli | 49 ++----------------------- 6 files changed, 26 insertions(+), 200 deletions(-) diff --git a/cohttp/oauth_cohttp_http.ml b/cohttp/oauth_cohttp_http.ml index 58dbb43..bc93174 100644 --- a/cohttp/oauth_cohttp_http.ml +++ b/cohttp/oauth_cohttp_http.ml @@ -6,12 +6,12 @@ let (>>=) = Lwt.bind module Monad = Lwt -type status = C.Code.status_code +type status_code = int type meth = C.Code.meth type request = CU.Server.Request.t -exception Error of status * string +exception Error of status_code * string let http_method = CU.Request.meth @@ -38,4 +38,5 @@ type response = (CU.Response.t * Cohttp_lwt_body.t) let respond req status headers body = let headers = C.Header.of_list headers in + let status = C.Code.status_of_code status in CU.Server.respond_string ~headers ~status ~body () diff --git a/cohttp/oauth_cohttp_http_client.ml b/cohttp/oauth_cohttp_http_client.ml index cb52df2..12b0db0 100644 --- a/cohttp/oauth_cohttp_http_client.ml +++ b/cohttp/oauth_cohttp_http_client.ml @@ -4,7 +4,7 @@ module CB = Cohttp_lwt_body let (>>=) = Lwt.bind -type status = C.Code.status_code +type status_code = int type meth = C.Code.meth module Opt = struct @@ -31,7 +31,7 @@ let request ?http_method ~url ?headers ?params ?body () = >>= function | None -> Lwt.fail (Failure "Connection did not succeed") | Some (response, body) -> - let status = CU.Response.status response in + let status = CU.Response.status response |> C.Code.code_of_status in let headers = C.Header.to_list (CU.Response.headers response) in CB.string_of_body body >>= fun body_string -> Lwt.return (status, headers, body_string) diff --git a/lib/oauth_client.ml b/lib/oauth_client.ml index 6d46038..3b13b30 100644 --- a/lib/oauth_client.ml +++ b/lib/oauth_client.ml @@ -8,50 +8,7 @@ sig val (>|=) : 'a t -> ('a -> 'b) -> 'b t end - type status = - [ `Accepted - | `Bad_gateway - | `Bad_request - | `Code of int - | `Conflict - | `Continue - | `Created - | `Expectation_failed - | `Forbidden - | `Found - | `Gateway_time_out - | `Gone - | `HTTP_version_not_supported - | `Internal_server_error - | `Length_required - | `Method_not_allowed - | `Moved_permanently - | `Multiple_choices - | `No_content - | `Non_authoritative_information - | `Not_acceptable - | `Not_found - | `Not_implemented - | `Not_modified - | `OK - | `Partial_content - | `Payment_required - | `Precondition_failed - | `Proxy_authentication_required - | `Request_URI_too_large - | `Request_entity_too_large - | `Request_time_out - | `Requested_range_not_satisfiable - | `Reset_content - | `See_other - | `Service_unavailable - | `Switching_protocols - | `Temporary_redirect - | `Unauthorized - | `Unprocessable_entity - | `Unsupported_media_type - | `Use_proxy ] - + type status_code = int type meth = [ `DELETE | `GET | `HEAD | `OPTIONS | `PATCH | `POST | `PUT ] val request : @@ -61,7 +18,7 @@ sig ?params:(string * string) list -> ?body:string * string -> (* content type * body *) unit -> - (status * (string * string) list * string) Monad.t + (status_code * (string * string) list * string) Monad.t end module Make (Http_client : Http_client) = @@ -69,12 +26,10 @@ struct open Http_client.Monad - exception Error of Http_client.status * string + exception Error of Http_client.status_code * string open Oauth_common - - let authorization_header ~oauth_version ~oauth_signature_method ~oauth_signature ~oauth_client ?oauth_token @@ -104,7 +59,7 @@ struct let params = Uri.query_of_encoded res |> List.map (fun (k,vs) -> k,List.hd vs) in (List.assoc "oauth_token" params, List.assoc "oauth_token_secret" params) with - | _ -> raise (Error (`Internal_server_error, "bad response: " ^ res)) + | _ -> raise (Error (500, "bad response: " ^ res)) @@ -138,7 +93,7 @@ struct ~headers ?params () >>= function - | (`OK, _, res) -> return (parse_response res) + | (200, _, res) -> return (parse_response res) | (status, _, res) -> fail (Error (status, res)) @@ -173,7 +128,7 @@ struct ~url ~headers () >>= function - | (`OK, _, res) -> return (parse_response res) + | (200, _, res) -> return (parse_response res) | (status, _, res) -> fail (Error (status, res)) @@ -211,7 +166,7 @@ struct ?params ?body () >>= function - | (`OK, _, res) -> return res + | (200, _, res) -> return res | (status, _, res) -> fail (Error (status, res)) end diff --git a/lib/oauth_client.mli b/lib/oauth_client.mli index d389bd8..269c812 100644 --- a/lib/oauth_client.mli +++ b/lib/oauth_client.mli @@ -8,50 +8,7 @@ sig val (>|=) : 'a t -> ('a -> 'b) -> 'b t end - type status = - [ `Accepted - | `Bad_gateway - | `Bad_request - | `Code of int - | `Conflict - | `Continue - | `Created - | `Expectation_failed - | `Forbidden - | `Found - | `Gateway_time_out - | `Gone - | `HTTP_version_not_supported - | `Internal_server_error - | `Length_required - | `Method_not_allowed - | `Moved_permanently - | `Multiple_choices - | `No_content - | `Non_authoritative_information - | `Not_acceptable - | `Not_found - | `Not_implemented - | `Not_modified - | `OK - | `Partial_content - | `Payment_required - | `Precondition_failed - | `Proxy_authentication_required - | `Request_URI_too_large - | `Request_entity_too_large - | `Request_time_out - | `Requested_range_not_satisfiable - | `Reset_content - | `See_other - | `Service_unavailable - | `Switching_protocols - | `Temporary_redirect - | `Unauthorized - | `Unprocessable_entity - | `Unsupported_media_type - | `Use_proxy ] - + type status_code = int type meth = [ `DELETE | `GET | `HEAD | `OPTIONS | `PATCH | `POST | `PUT ] val request : @@ -61,13 +18,12 @@ sig ?params:(string * string) list -> ?body:string * string -> (* content type * body *) unit -> - (status * (string * string) list * string) Monad.t + (status_code * (string * string) list * string) Monad.t end module Make : functor (Http_client : Http_client) -> sig - - exception Error of Http_client.status * string + exception Error of Http_client.status_code * string val fetch_temporary_credentials : ?http_method:Http_client.meth -> @@ -114,5 +70,4 @@ sig ?body:string * string -> (* content type * body *) unit -> string Http_client.Monad.t - end diff --git a/lib/oauth_server.ml b/lib/oauth_server.ml index 71a1be1..97cdcd1 100644 --- a/lib/oauth_server.ml +++ b/lib/oauth_server.ml @@ -8,49 +8,7 @@ sig val (>|=) : 'a t -> ('a -> 'b) -> 'b t end - type status = - [ `Accepted - | `Bad_gateway - | `Bad_request - | `Code of int - | `Conflict - | `Continue - | `Created - | `Expectation_failed - | `Forbidden - | `Found - | `Gateway_time_out - | `Gone - | `HTTP_version_not_supported - | `Internal_server_error - | `Length_required - | `Method_not_allowed - | `Moved_permanently - | `Multiple_choices - | `No_content - | `Non_authoritative_information - | `Not_acceptable - | `Not_found - | `Not_implemented - | `Not_modified - | `OK - | `Partial_content - | `Payment_required - | `Precondition_failed - | `Proxy_authentication_required - | `Request_URI_too_large - | `Request_entity_too_large - | `Request_time_out - | `Requested_range_not_satisfiable - | `Reset_content - | `See_other - | `Service_unavailable - | `Switching_protocols - | `Temporary_redirect - | `Unauthorized - | `Unprocessable_entity - | `Unsupported_media_type - | `Use_proxy ] + type status_code = int type meth = [ `DELETE | `GET | `HEAD | `OPTIONS | `PATCH | `POST | `PUT ] @@ -62,9 +20,9 @@ sig val arguments : request -> (string * string) list type response - val respond : request -> status -> (string * string) list -> string -> response Monad.t + val respond : request -> status_code -> (string * string) list -> string -> response Monad.t - exception Error of status * string + exception Error of status_code * string end module type DB = @@ -106,8 +64,8 @@ module Make (Db : DB with module Http = Http) = struct - let bad_request msg = raise (Http.Error (`Bad_request, msg)) - let unauthorized msg = raise (Http.Error (`Unauthorized, msg)) + let bad_request msg = raise (Http.Error (400, msg)) + let unauthorized msg = raise (Http.Error (401, msg)) let with_oauth_params req f = let arg = @@ -195,7 +153,7 @@ struct () then let request_token = Db.Temporary.make client_credentials req in - Http.respond req `OK [] + Http.respond req 200 [] (Uri.encoded_of_query [ "oauth_token", [Db.Temporary.key request_token]; "oauth_token_secret", [Db.Temporary.secret request_token]; @@ -238,7 +196,7 @@ struct let access_token = try Db.Token.exchange_temporary request_token with Failure msg -> unauthorized msg in - Http.respond req `OK [] + Http.respond req 200 [] (Uri.encoded_of_query [ "oauth_token", [Db.Token.key access_token]; "oauth_token_secret", [Db.Token.secret access_token]; @@ -267,7 +225,7 @@ struct | `POST -> Db.Temporary.authorize request_token req; kpost oauth_token request_token req - | _ -> raise (Http.Error (`Method_not_allowed, "")) + | _ -> raise (Http.Error (405, "")) with Http.Error (status, msg) -> Http.respond req status [] msg diff --git a/lib/oauth_server.mli b/lib/oauth_server.mli index bbd255c..74f4b10 100644 --- a/lib/oauth_server.mli +++ b/lib/oauth_server.mli @@ -8,50 +8,7 @@ sig val (>|=) : 'a t -> ('a -> 'b) -> 'b t end -type status = - [ `Accepted - | `Bad_gateway - | `Bad_request - | `Code of int - | `Conflict - | `Continue - | `Created - | `Expectation_failed - | `Forbidden - | `Found - | `Gateway_time_out - | `Gone - | `HTTP_version_not_supported - | `Internal_server_error - | `Length_required - | `Method_not_allowed - | `Moved_permanently - | `Multiple_choices - | `No_content - | `Non_authoritative_information - | `Not_acceptable - | `Not_found - | `Not_implemented - | `Not_modified - | `OK - | `Partial_content - | `Payment_required - | `Precondition_failed - | `Proxy_authentication_required - | `Request_URI_too_large - | `Request_entity_too_large - | `Request_time_out - | `Requested_range_not_satisfiable - | `Reset_content - | `See_other - | `Service_unavailable - | `Switching_protocols - | `Temporary_redirect - | `Unauthorized - | `Unprocessable_entity - | `Unsupported_media_type - | `Use_proxy ] - + type status_code = int type meth = [ `DELETE | `GET | `HEAD | `OPTIONS | `PATCH | `POST | `PUT ] type request @@ -62,9 +19,9 @@ type status = val arguments : request -> (string * string) list type response - val respond : request -> status -> (string * string) list -> string -> response Monad.t + val respond : request -> status_code -> (string * string) list -> string -> response Monad.t - exception Error of status * string + exception Error of status_code * string end module type DB =