From 2fbad4de4e6bfcc8dfa6b0fc53b3afff84a3cc34 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Mon, 31 Oct 2016 18:26:16 +0100 Subject: [PATCH] Remove extensions (Eliom_{atom,openid}) --- pkg/META | 9 - pkg/build.ml | 6 - pkg/filelist.ml | 8 +- src/_tags | 7 - src/lib/server/extensions/atom_feed.ml | 299 ----------- src/lib/server/extensions/atom_feed.mli | 258 --------- src/lib/server/extensions/eliom_atom.ml | 137 ----- src/lib/server/extensions/eliom_atom.mli | 36 -- src/lib/server/extensions/eliom_openid.ml | 587 --------------------- src/lib/server/extensions/eliom_openid.mli | 273 ---------- src/lib/server/extensions/eliom_s2s.ml | 117 ---- src/lib/server/extensions/eliom_s2s.mli | 53 -- 12 files changed, 1 insertion(+), 1789 deletions(-) delete mode 100644 src/lib/server/extensions/atom_feed.ml delete mode 100644 src/lib/server/extensions/atom_feed.mli delete mode 100644 src/lib/server/extensions/eliom_atom.ml delete mode 100644 src/lib/server/extensions/eliom_atom.mli delete mode 100644 src/lib/server/extensions/eliom_openid.ml delete mode 100644 src/lib/server/extensions/eliom_openid.mli delete mode 100644 src/lib/server/extensions/eliom_s2s.ml delete mode 100644 src/lib/server/extensions/eliom_s2s.mli diff --git a/pkg/META b/pkg/META index 2070ad518e..c414751261 100644 --- a/pkg/META +++ b/pkg/META @@ -20,15 +20,6 @@ package "server" ( archive(byte) = "server.cma" archive(native) = "server.cmxa" - package "ext" ( - directory = "extensions" - description = "Eliom: server-side extensions" - version = "[distributed with Eliom]" - require = "eliom.server" - archive(byte) = "extensions.cma" - archive(native) = "extensions.cmxa" - ) - package "monitor" ( directory = "monitor" description = "Eliom: monitoring" diff --git a/pkg/build.ml b/pkg/build.ml index 091aaa69f6..ba03dec607 100755 --- a/pkg/build.ml +++ b/pkg/build.ml @@ -21,8 +21,6 @@ let _ = list_to_file "src/lib/server/server.mllib" server_mllib; list_to_file "src/lib/server/server.mldylib" server_mllib; - list_to_file "src/lib/server/extensions/extensions.mllib" server_ext_mllib; - list_to_file "src/lib/server/extensions/extensions.mldylib" server_ext_mllib; list_to_file "src/lib/server/api.odocl" server_api; list_to_file "src/ocamlbuild/ocamlbuild.mllib" ocamlbuild_mllib; @@ -107,10 +105,6 @@ let () = Pkg.lib ~dst:"server/monitor/eliom_monitor_main" ~exts:Exts.module_library "src/lib/server/monitor/eliom_monitor_main" :: Pkg.lib ~dst:"server/server" ~exts:exts_lib "src/lib/server/server" :: List.map (fun x -> Pkg.lib ~dst:(spf "server/%s" x) (spf "src/lib/server/%s" x)) server_extra - ) @ ( - (* SERVER EXTENSIONS *) - Pkg.lib ~dst:"server/extensions/extensions" ~exts:exts_lib "src/lib/server/extensions/extensions" :: - List.map (fun x -> Pkg.lib ~dst:(spf "server/extensions/%s" x) (spf "src/lib/server/extensions/%s" x)) server_ext_extra ) @ [ (* MISC *) diff --git a/pkg/filelist.ml b/pkg/filelist.ml index 25cb3506ec..9023b484f1 100644 --- a/pkg/filelist.ml +++ b/pkg/filelist.ml @@ -185,13 +185,7 @@ let server_extra = exts ["cmx"] (server.interface @ server.internal) let server_api = - let names = - server.interface_only @ - server.interface @ - List.map (fun e -> "extensions/" ^ e) - (server_ext.interface_only @ server_ext.interface) - in - names + server.interface_only @ server.interface let server_ext_mllib = server_ext.interface @ server_ext.internal let server_ext_extra = diff --git a/src/_tags b/src/_tags index 6ef0f5abbe..891a97c5bf 100644 --- a/src/_tags +++ b/src/_tags @@ -28,13 +28,6 @@ true:keep_locs :package(js_of_ocaml.deriving.ppx) -:package(js_of_ocaml.deriving.ppx,lwt.ppx) - -:thread -:package(lwt,ocsigenserver,ocsigenserver.ext,tyxml,calendar) -:package(js_of_ocaml.deriving.ppx) -:I(src/lib/server) - :package(lwt.ppx) :thread :package(lwt,ocsigenserver,ocsigenserver.ext,tyxml,calendar) diff --git a/src/lib/server/extensions/atom_feed.ml b/src/lib/server/extensions/atom_feed.ml deleted file mode 100644 index 7a5b100142..0000000000 --- a/src/lib/server/extensions/atom_feed.ml +++ /dev/null @@ -1,299 +0,0 @@ -(* Ocsigen - * Copyright (C) 2010 Archibald Pontier - * - * This source file is part of Ocsigen < http://ocsigen.org/ > - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, with linking exception; - * either version 2.1 of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - *) - -open Eliom_lib - -(* - * types {{{ - *) -type uri = Tyxml_xml.uri -type lang = string -type base = uri -type ncname = string -type dateConstruct = string -type emailAddress = string -type mediaType = string -type length = int -type href = Tyxml_xml.uri -type hrefLang = string -type rel = string -type ltitle = string -type scheme = string -type label = string -type term = string -type metaAttr = [ `Base of base | `Lang of lang ] -type personConstruct = [ `Uri of uri | `Email of emailAddress ] -type author = Tyxml_xml.elt -type contributor = Tyxml_xml.elt -type generator = Tyxml_xml.elt -type id = Tyxml_xml.elt -type icon = Tyxml_xml.elt -type category = Tyxml_xml.elt -type link = Tyxml_xml.elt -type logo = Tyxml_xml.elt -type published = Tyxml_xml.elt -type updated = Tyxml_xml.elt -type source = Tyxml_xml.elt -type entry = Tyxml_xml.elt -type feed = Tyxml_xml.elt -type content = Tyxml_xml.elt -type textConstruct = Tyxml_xml.attrib list * Tyxml_xml.elt list -type linkOAttr = [ metaAttr - | `Type of string - | `Rel of rel - | `Medtype of mediaType - | `Hrefl of hrefLang - | `Title of ltitle - | `Length of length ] -type sourceOAttr = [ metaAttr - | `Authors of author list - | `Cats of category list - | `Contribs of contributor list - | `Gen of generator - | `Icon of icon - | `Links of link list - | `Logo of logo - | `Rights of textConstruct - | `Sub of textConstruct ] -type entryOAttr = [ metaAttr - | `Authors of author list - | `Cats of category list - | `Content of content - | `Contribs of contributor list - | `Links of link list - | `Pub of published - | `Rights of textConstruct - | `Source of source - | `Sum of textConstruct ] -type feedOAttr = [ metaAttr - | `Authors of author list - | `Cats of category list - | `Contribs of contributor list - | `Gen of generator - | `Icon of icon - | `Links of link list - | `Logo of logo - | `Rights of textConstruct - | `Sub of textConstruct ] -(* - * }}} - *) - -(* - * Constructors {{{ - *) - -let date d = CalendarLib.Printer.Calendar.sprint "%iT%TZ" d -let xml_of_feed f = f - -(* - * attr converters {{{ - *) -let a_base = Tyxml_xml.uri_attrib "base" -let a_lang = Tyxml_xml.string_attrib "lang" -let a_scheme = Tyxml_xml.string_attrib "scheme" -let a_label = Tyxml_xml.string_attrib "label" -let a_href = Tyxml_xml.uri_attrib "href" -let a_rel = Tyxml_xml.string_attrib "rel" -let a_hreflang = Tyxml_xml.string_attrib "hreflang" -let a_medtype = Tyxml_xml.string_attrib "mediatype" -let a_title = Tyxml_xml.string_attrib "title" -let a_length = Tyxml_xml.int_attrib "length" -let a_term = Tyxml_xml.string_attrib "term" -let a_type = Tyxml_xml.string_attrib "type" -(* - * }}} - *) - -let rec metaAttr_extract l = match l with - | [] -> [] - | `Base a :: r -> a_base a :: metaAttr_extract r - | `Lang a :: r -> a_lang a :: metaAttr_extract r | _ :: r -> - metaAttr_extract r - -let rec c_pcdata l = match l with | [] -> [] | a::r -> Tyxml_xml.pcdata a :: c_pcdata -r - -let print_html5 l = - let buffer = Buffer.create 500 in - let output = Buffer.add_string buffer in - let encode x = fst (Xml_print.Utf8.normalize_html x) in - Eliom_content.Html.Printer.print_list ~encode ~output l; - Buffer.contents buffer - -let inlineC ?(meta = []) ?(html = false) c = `Content (Tyxml_xml.node ~a:(a_type (if - html then "html" else "text") :: metaAttr_extract meta) "content" - (c_pcdata c)) - -let html5C ?meta c = - inlineC ?meta ~html:true [print_html5 [Eliom_content.Html.F.div c]] - -let inlineOtherC ?(meta = []) (a,b) = `Content (Tyxml_xml.node ~a:(a_medtype a :: - metaAttr_extract meta) "content" b) - -let outOfLineC ?(meta = []) (a,b) = `Content (Tyxml_xml.node ~a:(a_medtype a :: - Tyxml_xml.uri_attrib "src" b :: metaAttr_extract meta) "content" []) - -(* - * Extraction functions {{{ - *) -let rec personConstruct_extract l = match l with - | [] -> [] - |`Email a :: r -> Tyxml_xml.node ~a:[] "email" [(Tyxml_xml.pcdata a)] :: - personConstruct_extract r - | `Uri a :: r -> Tyxml_xml.node ~a:[] "uri" [(Tyxml_xml.pcdata (Tyxml_xml.string_of_uri a))] :: - personConstruct_extract r - | _ :: r -> personConstruct_extract r - -let rec linkOAttr_extract l = match l with - | [] -> [] - | `Type a :: r -> Tyxml_xml.string_attrib "type" a :: linkOAttr_extract r - | `Rel a :: r -> a_rel a :: linkOAttr_extract r - | `Medtype a :: r -> a_medtype a :: linkOAttr_extract r - | `Hrefl a :: r -> a_hreflang a :: linkOAttr_extract r - | `Title a :: r -> a_title a :: linkOAttr_extract r - | `Length a :: r -> a_length a :: linkOAttr_extract r - | _ :: r -> linkOAttr_extract r - -let rec sourceOAttr_extract l = match l with - | [] -> [] - | `Authors a :: r - | `Cats a :: r - | `Contribs a :: r - | `Links a :: r -> a @ sourceOAttr_extract r - | `Gen a :: r - | `Icon a :: r - | `Logo a :: r -> a :: sourceOAttr_extract r - | `Rights (a,b) :: r -> Tyxml_xml.node ~a "rights" b :: sourceOAttr_extract r - | `Sub (a,b) :: r -> Tyxml_xml.node ~a "subtitle" b :: sourceOAttr_extract r - | _ :: r -> sourceOAttr_extract r - -let rec entryOAttr_extract l = match l with - | [] -> [] - | `Authors a :: r - | `Cats a :: r - | `Contribs a :: r - | `Links a :: r -> a @ entryOAttr_extract r - | `Content a :: r - | `Pub a :: r - | `Source a :: r -> a :: entryOAttr_extract r - | `Rights (a,b) :: r -> Tyxml_xml.node ~a "rights" b :: entryOAttr_extract r - | `Sum (a,b) :: r -> Tyxml_xml.node ~a "summary" b :: entryOAttr_extract r - | _ :: r -> entryOAttr_extract r - -let rec feedOAttr_extract l = match l with - | [] -> [] - | `Authors a :: r - | `Cats a :: r - | `Contribs a :: r - | `Links a :: r -> a @ feedOAttr_extract r - | `Gen a :: r - | `Icon a :: r - | `Logo a :: r -> a :: feedOAttr_extract r - | `Rights (a,b) :: r -> Tyxml_xml.node ~a "rights" b :: feedOAttr_extract r - | `Sub (a,b) :: r -> Tyxml_xml.node ~a "subtitle" b :: feedOAttr_extract r - | _ :: r -> feedOAttr_extract r - (* - * }}} - *) - -(* - * Textconstructs [Rights, Subtitle, Summary, Title] {{{ - *) -let plain ?(meta = []) ?(html = false) content = (Tyxml_xml.string_attrib "type" - (if html then "html" else "text"):: metaAttr_extract meta, [Tyxml_xml.pcdata - content]) - -let html5 ?meta content = - plain ?meta ~html:true (print_html5 content) - -let rights t = `Rights t - -let subtitle t = `Sub t - -let summary t = `Sum t - (* - * }}} - *) - -let feed ~updated ~id ~title:(a,b) ?(fields = []) entries = - Tyxml_xml.node ~a:(Tyxml_xml.string_attrib "xmlns" "http://www.w3.org/2005/Atom" :: - metaAttr_extract fields) - "feed" - (Tyxml_xml.node ~a:[] "updated" [ Tyxml_xml.pcdata (date updated) ] :: - Tyxml_xml.node ~a:[] "id" [ Tyxml_xml.pcdata (Tyxml_xml.string_of_uri id) ] :: Tyxml_xml.node ~a "title" b :: - feedOAttr_extract fields @ entries) - -let entry ~updated ~id ~title:(a,b) elt = - Tyxml_xml.node ~a:(metaAttr_extract elt) - "entry" - (Tyxml_xml.node ~a:[] "updated" [ Tyxml_xml.pcdata (date updated) ] :: - Tyxml_xml.node ~a:[] "id" [ Tyxml_xml.pcdata (Tyxml_xml.string_of_uri id) ] :: - Tyxml_xml.node ~a "title" b :: - entryOAttr_extract elt) - -let source ~updated ~id ~title:(a,b) elt = `Source ( - Tyxml_xml.node ~a:(metaAttr_extract elt) - "source" - (Tyxml_xml.node ~a:[] "updated" [ Tyxml_xml.pcdata (date updated) ] :: - Tyxml_xml.node ~a:[] "id" [ Tyxml_xml.pcdata (Tyxml_xml.string_of_uri id) ] :: - Tyxml_xml.node ~a "title" b :: sourceOAttr_extract elt) - ) - -let link ?(elt = []) href = Tyxml_xml.leaf ~a:(a_href href :: (linkOAttr_extract elt) - @ (metaAttr_extract elt)) "link" - -let links l = `Links l - -let email s = `Email s - -let uri s = `Uri s - -let author ?(elt = []) name = Tyxml_xml.node ~a:[] "author" (Tyxml_xml.node ~a:[] "name" - [Tyxml_xml.pcdata name] :: personConstruct_extract elt) - -let authors l = `Authors l - -let contributor ?(elt = []) name = Tyxml_xml.node ~a:[] "contributor" (Tyxml_xml.node ~a:[] - "name" [Tyxml_xml.pcdata name] :: personConstruct_extract elt) - -let contributors l = `Contribs l - -let icon address = `Icon (Tyxml_xml.node ~a:[] "icon" [ Tyxml_xml.pcdata (Tyxml_xml.string_of_uri address) ]) - -let logo address = `Logo (Tyxml_xml.node ~a:[] "icon" [ Tyxml_xml.pcdata (Tyxml_xml.string_of_uri address) ]) - -let category ?(meta = []) ?(scheme = "") ?(label = "") term content = - Tyxml_xml.node ~a:(a_scheme scheme :: a_label label :: - a_term term :: metaAttr_extract meta) - "category" - content - -let categories l = `Cats l - -let published d = `Pub (Tyxml_xml.node ~a:[] "published" [ Tyxml_xml.pcdata (date d) ]) - -(* - * }}} - *) - -let insert_hub_links hubs feed = match Tyxml_xml.content feed with - | Tyxml_xml.Node (b, a, c) -> Tyxml_xml.node ~a b (List.map - (fun uri -> link ~elt:[`Rel ("hub")] uri) hubs @ c) | _ -> assert false diff --git a/src/lib/server/extensions/atom_feed.mli b/src/lib/server/extensions/atom_feed.mli deleted file mode 100644 index 347ba72826..0000000000 --- a/src/lib/server/extensions/atom_feed.mli +++ /dev/null @@ -1,258 +0,0 @@ -(* Ocsigen - * Copyright (C) 2010 Archibald Pontier - * - * This source file is part of Ocsigen < http://ocsigen.org/ > - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, with linking exception; - * either version 2.1 of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - *) - -(** Everything we need to make an atom feed. *) - -(* - * types {{{ - *) -type uri = Tyxml_xml.uri -type lang = string -type base = uri -type ncname = string -type dateConstruct = string -type emailAddress = string -type mediaType = string -type length = int -type href = Tyxml_xml.uri -type hrefLang = string -type rel = string -type ltitle = string -type scheme = string -type label = string -type term = string - -(** Common optional attributes *) -type metaAttr = [ `Base of base | `Lang of lang ] - -(** Children tags allowed for the author and contributor tags *) -type personConstruct = [ `Email of emailAddress | `Uri of uri ] - -type author -type contributor -type generator -type id -type icon -type category -type link -type logo -type published -type updated -type source -type entry -type feed -type content -type textConstruct - -(** Children tags allowed for the link tag *) -type linkOAttr = [ metaAttr - | `Type of string - | `Hrefl of hrefLang - | `Length of length - | `Medtype of mediaType - | `Rel of rel - | `Title of ltitle ] - -(** Children tags allowed for the source tag *) -type sourceOAttr = [ metaAttr - | `Authors of author list - | `Cats of category list - | `Contribs of contributor list - | `Gen of generator - | `Icon of icon - | `Links of link list - | `Logo of logo - | `Rights of textConstruct - | `Sub of textConstruct ] - -(** Children tags allowed for the entry tag *) -type entryOAttr = [ metaAttr - | `Authors of author list - | `Cats of category list - | `Content of content - | `Contribs of contributor list - | `Links of link list - | `Pub of published - | `Rights of textConstruct - | `Source of source - | `Sum of textConstruct ] - -(** Children tags allowed for the feed tag *) -type feedOAttr = [ metaAttr - | `Authors of author list - | `Cats of category list - | `Contribs of contributor list - | `Gen of generator - | `Icon of icon - | `Links of link list - | `Logo of logo - | `Rights of textConstruct - | `Sub of textConstruct ] -(* - * }}} - *) - -(* - * Constructors {{{ - *) - -val xml_of_feed : feed -> Tyxml_xml.elt - -(* - * attr converters {{{ -val a_base : base -> Tyxml_xml.attrib -val a_lang : lang -> Tyxml_xml.attrib -val a_scheme : scheme -> Tyxml_xml.attrib -val a_label : label -> Tyxml_xml.attrib -val a_href : href -> Tyxml_xml.attrib -val a_rel : rel -> Tyxml_xml.attrib -val a_hreflang : hrefLang -> Tyxml_xml.attrib -val a_medtype : mediaType -> Tyxml_xml.attrib -val a_title : ltitle -> Tyxml_xml.attrib -val a_length : length -> Tyxml_xml.attrib -val a_term : term -> Tyxml_xml.attrib -val a_type : string -> Tyxml_xml.attrib - * }}} - *) - -(** An inline text or html content *) -val inlineC : ?meta:[> metaAttr ] list - -> ?html:bool - -> string list - -> [> `Content of content ] - -(** An html5 content, embedded in a div *) -val html5C : ?meta:[> metaAttr ] list - -> ([ `PCDATA | Html_types.flow5 ] Eliom_content.Html.elt list) - -> [> `Content of content ] - -(** Inline content from another kind *) -val inlineOtherC : ?meta:[> metaAttr ] list - -> string * Tyxml_xml.elt list - -> [> `Content of content ] - -(** Every other content *) -val outOfLineC : ?meta:[> metaAttr ] list - -> string * uri - -> [> `Content of content ] - -(** Plain text construct *) -val plain : ?meta:[> metaAttr ] list - -> ?html:bool - -> string - -> textConstruct - -(** HTML5 text construct *) -val html5 : ?meta:[> metaAttr ] list - -> [ `PCDATA | Html_types.flow5 ] Eliom_content.Html.elt list - -> textConstruct - -(** Rights tag *) -val rights : textConstruct - -> [> `Rights of textConstruct ] - -(** Subtitle tag *) -val subtitle : textConstruct - -> [> `Sub of textConstruct ] - -(** Summary tag *) -val summary : textConstruct - -> [> `Sum of textConstruct ] - -(** Feed tag *) -val feed : updated:CalendarLib.Calendar.t - -> id:uri - -> title:textConstruct - -> ?fields:[> feedOAttr ] list - -> entry list - -> feed - -(** Entry tag *) -val entry : - updated:CalendarLib.Calendar.t -> - id:uri -> - title:textConstruct -> - [> entryOAttr ] list -> entry - -(** Source tag *) -val source : - updated:CalendarLib.Calendar.t -> - id:uri -> - title:textConstruct -> - [> sourceOAttr ] list -> [> `Source of source ] - -(** Link tag *) -val link : - ?elt:[> linkOAttr ] list -> - href -> link - - -(** We need a list of links, this is only a converter from link list to `Links - *) -val links : link list -> [> `Links of link list ] - -(** email tag *) -val email : string -> [> `Email of string ] - -(** uri tag, basically, simply a converter *) -val uri : uri -> [> `Uri of uri ] - -(** author tag *) -val author : - ?elt:[> personConstruct ] list -> string -> author - -(** We need a list of authors, this is only a converter from author list to - `Authors *) -val authors : author list -> [> `Authors of author list ] - -(** contributor tag *) -val contributor : - ?elt:[> personConstruct ] list -> string -> contributor - -(** We need a list of contributors, this is only a converter from contributor - list to `Contributors *) -val contributors : contributor list -> [> `Contribs of contributor list ] - -(** icon tag, basically, simply a converter *) -val icon : uri -> [> `Icon of icon ] - -(** logo tag, basically, simply a converter *) -val logo : uri -> [> `Logo of logo ] - -(** category tag *) -val category : - ?meta:[> metaAttr ] list -> - ?scheme:scheme -> ?label:label -> - term -> Tyxml_xml.elt list -> category - -(** We need a list of categories, this is only a converter from category list - to `Categories *) -val categories : category list -> [> `Cats of category list] - -(* published tag *) -val published : CalendarLib.Calendar.t -> [> `Pub of published ] - -(* - * }}} - *) - -(** Technically not used elsewhere than in eliom_feed.ml, since the links tags - related to each hub are added when registering the feed. *) -val insert_hub_links : uri list -> feed -> feed diff --git a/src/lib/server/extensions/eliom_atom.ml b/src/lib/server/extensions/eliom_atom.ml deleted file mode 100644 index ff0bd5672a..0000000000 --- a/src/lib/server/extensions/eliom_atom.ml +++ /dev/null @@ -1,137 +0,0 @@ -(* Ocsigen - * Copyright (C) 2010 Archibald Pontier - * - * This source file is part of Ocsigen < http://ocsigen.org/ > - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, with linking exception; - * either version 2.1 of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - *) - -open Eliom_lib - -module F = Ocsigen_http_frame -module H = Ocsigen_http_frame.Http_header - -let get_etag c = Some (Digest.to_hex (Digest.string c)) - -module Atom_info = struct - let content_type = "application/atom+xml" - let version = "Atom 1.0" - let standard = "http://www.w3.org/2005/Atom" - let doctype = "" - let emptytags = [] -end - -module Format = Xml_print.Make_simple(Tyxml_xml)(Atom_info) - -let result_of_content feed headers = - let b = Buffer.create 10 in - let encode x = fst (Xml_print.Utf8.normalize_html x) in - Format.print_list ~output:(Buffer.add_string b) ~encode [Atom_feed.xml_of_feed feed]; - let c = Buffer.contents b in - let md5 = get_etag c in - let dr = Ocsigen_http_frame.Result.default () in - (Ocsigen_http_frame.Result.update dr - ~content_length:(Some (Int64.of_int (String.length c))) - ~content_type:(Some "application/atom+xml") - ~etag:md5 - ~headers:(match headers with - | None -> Ocsigen_http_frame.Result.headers dr - | Some headers -> - Http_headers.with_defaults headers (Ocsigen_http_frame.Result.headers dr) - ) - ~stream: - (Ocsigen_stream.make - (fun () -> - Ocsigen_stream.cont c - (fun () -> Ocsigen_stream.empty None)), None) - ()) - -module Reg_base = struct - type page = Atom_feed.feed - type options = unit - type result = Eliom_registration.browser_content Eliom_registration.kind - let result_of_http_result = Eliom_registration.cast_http_result - let send_appl_content = Eliom_service.XNever - let pre_service ?options () = Lwt.return () - let send ?options ?charset ?code ?content_type ?headers feed = - Lwt.return (result_of_content feed headers ) -end - -module Reg = Eliom_mkreg.Make(Reg_base) - -let (>>=) = Lwt.bind - -type feed = { notify_updates : unit -> unit } - -let retry_after = Http_headers.name "Retry-After" - -open CalendarLib - -let section = Lwt_log.Section.make "eliom:atom" -let log_error e = Lwt_log.ign_warning_f ~section "Error while contacting hub: %s" (Printexc.to_string e) - -let parse_503 header = let r_int = Str.regexp "^[0-9]+$" in - let r_date = Str.regexp - "[a-zA-Z]+,.[0-9]+ [a-zA-Z]+ [0-9]+ [0-9]+:[0-9]+:[0-9]+ GMT" in - if Str.string_match r_int header 0 then Lwt_unix.sleep - (float_of_string header) - else if Str.string_match r_date header 0 then let d = Time_Zone.on - CalendarLib.Calendar.to_unixfloat Time_Zone.UTC - (CalendarLib.Printer.Calendar.from_fstring - "%a, %d %b %Y %H:%M:%S GMT" header) in - let d2 = Unix.gettimeofday () in - let d3 = d -. d2 in - if d3 < 0. then failwith "bad retry-after header" - else if d3 > 7200. then Lwt_unix.sleep 7200. - else Lwt_unix.sleep d3 - else failwith "bad retry-after header" - -let rec ping_hub u address t = - Lwt.try_bind - (fun () -> let path = Neturl.join_path (Neturl.url_path u) in - Ocsigen_http_client.post_urlencoded ~port:(try Neturl.url_port u with - Not_found -> 80) ~host:(Neturl.url_host u) - ~uri:(if path = "" then "/" else path) - ~content:[("hub.mode","publish"); ("hub.url",address)] ()) - (fun frame -> match frame.F.frame_header.H.mode with - | H.Answer 204 -> Lwt.return () - | H.Answer 503 -> Lwt.try_bind (fun () -> parse_503 (Http_headers.find - retry_after frame.F.frame_header.H.headers)) (fun () -> - ping_hub u address 1.) (fun e -> log_error e ; retry_ping u address t) - | _ -> retry_ping u address t) - (fun e -> log_error e ; retry_ping u address t) - and retry_ping u address t = Lwt_unix.sleep (Random.float t) >>= - (fun () -> ping_hub u address (t*.2.)) - -let rec nfu_s hubs address = match hubs with - | [] -> () - | s :: r -> let u = Neturl.parse_url (Tyxml_xml.string_of_uri s) in ignore (ping_hub u address 1.) ; - nfu_s r address - -let notify_feed_updates address hubs s = - nfu_s hubs address; () - -let register_feed ~path ~hubs address f = - let s = - Eliom_service.create - ~meth:(Eliom_service.Get Eliom_parameter.unit) - ~path:(Eliom_service.Path path) - () - in - Reg.register ~service:s - (fun () () -> f () >>= fun feed -> Lwt.return - (Atom_feed.insert_hub_links hubs feed)); - notify_feed_updates address hubs s; - {notify_updates = fun () -> notify_feed_updates address hubs s} diff --git a/src/lib/server/extensions/eliom_atom.mli b/src/lib/server/extensions/eliom_atom.mli deleted file mode 100644 index 704a2dc849..0000000000 --- a/src/lib/server/extensions/eliom_atom.mli +++ /dev/null @@ -1,36 +0,0 @@ -(* Ocsigen - * Copyright (C) 2010 Archibald Pontier - * - * This source file is part of Ocsigen < http://ocsigen.org/ > - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, with linking exception; - * either version 2.1 of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - *) - -(** Register an atom feed *) -module Reg : Eliom_registration_sigs.S - with type page = Atom_feed.feed - and type options = unit - and type return = Eliom_service.non_ocaml - and type result = - Eliom_registration.browser_content Eliom_registration.kind - -(** Needed when used with Pubsubhubbub *) -type feed = { notify_updates : unit -> unit } - -(** Add the needed for each hub in the feed, and - communicate with the hub *) -val register_feed : - path:string list -> hubs:Atom_feed.uri list -> string -> - (unit -> Atom_feed.feed Lwt.t) -> feed diff --git a/src/lib/server/extensions/eliom_openid.ml b/src/lib/server/extensions/eliom_openid.ml deleted file mode 100644 index c893e65748..0000000000 --- a/src/lib/server/extensions/eliom_openid.ml +++ /dev/null @@ -1,587 +0,0 @@ -(* Ocsigen - * Copyright (C) 2010 Simon Castellan - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, with linking exception; - * either version 2.1 of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - *) - -open Eliom_lib -open Eliom_s2s -open Ocsigen_stream -open Lwt -open Simplexmlparser -open Ocsigen_http_frame -open Cryptokit -open Eliom_parameter -open Ocsigen_headers -module Base64 = Netencoding.Base64 - -let section = Lwt_log.Section.make "eliom:openid" - -type openid_error = - | Invalid_XRDS_File of string * string - | Discovery_Error of string * string - | Missing_parameter of string - | Invalid_signature of string * string - | Invalid_association of string - | Invalid_argument of string * string * string - | Server_error of string - | Invalid_answer of string - | Invalid_html_doc of string -let string_of_openid_error = function - | Invalid_XRDS_File (url, error) -> - Printf.sprintf "While parsing XRDS document at %s: %s" url error - | Discovery_Error (url, error) -> - Printf.sprintf "While fetching url %s: %s" url error - | Missing_parameter name -> - Printf.sprintf "Missing parameter: %s" name - | Invalid_signature (ours, theirs) -> - Printf.sprintf "Invalid signature: computed:'%s', got: '%s'" ours theirs - | Invalid_association s -> - "Invalid association with "^s - | Invalid_argument (arg, v, value) -> - Printf.sprintf "Invalid argument: %s. Got %s, expected %s" arg v value - | Server_error s -> - Printf.sprintf "Server error: %s" s - | Invalid_answer s -> - Printf.sprintf "Invalid server answer: %s" s - | Invalid_html_doc url -> - Printf.sprintf "Invalid HTML document (could not find endpoint): %s\n" url -exception Error of openid_error - -let failwith e = raise (Error e) -let lwt_fail e = Lwt.fail (Error e) - -(* COMMON *) -let ( &&& ) g1 g2 = g1 >>= (fun () -> g2) - -let guard b e = if b then Lwt.return () else lwt_fail e - -let get args name = - try - List.assoc name args - with Not_found -> failwith (Missing_parameter name) -let check_arg args arg value = - let v = get args arg in - if v = value then Lwt.return () - else lwt_fail (Invalid_argument (arg, v, value)) - -let ( ^? ) a b = match a with - | Some x -> x :: b - | None -> b - -let ( ^^? ) (b, x) l = if b then x :: l else l -let openid_url = "http://specs.openid.net/auth/2.0" -let direct_request ~mode ~params ~endpoint = - let params = push_ns ~namespace_param:("ns", openid_url) "openid" (("mode", mode) :: params) in - direct_request params endpoint - -(* DISCOVERY *) -(* This part is dedicated to discover the OpenID service attached - to a given endpoint. To do so, we do a GET request towards a remote file - that may be in two forms : - - An XRDS file describing a list of service. For now we take the one with the - higher priority. - - An html file in which we have to seek for two tags. -*) -(* XRDS parsing *) -let parse_xrds url xml = - let parse_item (endpoint, local) = function - | Element ("URI", _, [PCData uri]) -> - (uri, local) - | Element ("LocalID", _, [PCData id]) -> - (endpoint, Some id) - | _ -> (endpoint, local) - in - let parse_service = function - | Element ("Service", attrs, children) -> - let priority = - try - snd (List.find (function ("priority", _) -> true | _ -> false) attrs) - with Not_found -> failwith (Invalid_XRDS_File (url, "Priority expected")) - in - (int_of_string priority, List.fold_left parse_item ("", None) children) - | _ -> failwith (Invalid_XRDS_File (url, "Service expected")) - in - match xml with - | [Element ("xrds:XRDS", _, [Element ("XRD", _, services)])] -> - List.map parse_service services - | _ -> - failwith (Invalid_XRDS_File (url, "Wrong root XML element")) -(* Select the best service *) -let select_service services = List.fold_left - (fun ((a, _) as data) ((b, _) as data') -> if b < a then data' else data) - (List.hd services) - (List.tl services) - -(* HTML Parsing *) -(* About this function: - We cannot afford putting the whole page in memory and parsing - it, and then looking for some tags. Some pages are actually - too big for that. So we parse chunk by chunk the stream given by - Ocsigen_http_client, seeking for some particular regexp. - Where the fun part goes is that some providers don't bother using valid XML, so - we have something like (myopenid.net). - Fortunately for the link we're interested in, they seem to respect the standard - so we ignore the ones where Simplexmlparser fails, crossing the fingers. *) -let parse_html url stream = - let server = ref "" and delegate = ref (Some url) in - let rec loop acc st = Ocsigen_stream.next st >>= - (function - | Ocsigen_stream.Finished (Some st) -> loop acc st - | Ocsigen_stream.Finished None -> - if !server = "" then - lwt_fail (Invalid_html_doc url) - else - Lwt.return (!server, !delegate) - | Ocsigen_stream.Cont (suite, st) -> - compute_match (acc ^ suite) st) - and compute_match acc st = - let regexp = Netstring_pcre.regexp "< *link[^>]*>" in - let next acc = loop acc st in - try - let (k, r) = Netstring_pcre.search_forward regexp acc 0 in - let m = Netstring_pcre.matched_string r acc in - (try - match Simplexmlparser.xmlparser_string m with - | Element ("link", attrs, _) :: _ -> - if List.mem ("rel", "openid.server") attrs then - server := List.assoc "href" attrs - else if List.mem ("rel", "openid.delegate") attrs then - delegate := Some (List.assoc "href" attrs) - | _ -> () - with _ -> ()); - let s' = String.sub acc (k + String.length m) (String.length acc - String.length m - k) in - compute_match s' st - with Not_found -> - let k = String.rindex acc '<' in - next (String.sub acc k (String.length acc - k)) - - in - loop "" stream - -(* Request end-point *) -(* DO NOT HANDLE XRIs *) -let normalize url = - let starts_with s = - String.length url > String.length s - && String.sub url 0 (String.length s) = s in - if not (starts_with "http://") && not (starts_with "https://") then - "http://" ^ url - else - url -let perform_discovery url = - let url = normalize url in - do_get_request url >>= (fun frame -> - match frame.frame_content with - | None -> failwith (Discovery_Error (url, "Empty body")) - | Some content -> - let content = Ocsigen_stream.get content in - match Ocsigen_headers.parse_content_type (get_content_type frame) with - | Some ((_, "xrds+xml"), _) -> - string_of_stream 100000 content >>= (fun s -> - let xml = Simplexmlparser.xmlparser_string s in - let _, service = select_service (parse_xrds url xml) in - Lwt.return service) - | _ -> parse_html url content) - - -(* CRYPT *) - -(* this is default modulus and generator given by the openid spec. *) -let modulus = "\xDC\xF9\x3A\x0B\x88\x39\x72\xEC\x0E\x19\x98\x9A\xC5\xA2\xCE\x31\x0E\x1D\x37\x71\x7E\x8D\x95\x71\xBB\x76\x23\x73\x18\x66\xE6\x1E\xF7\x5A\x2E\x27\x89\x8B\x05\x7F\x98\x91\xC2\xE2\x7A\x63\x9C\x3F\x29\xB6\x08\x14\x58\x1C\xD3\xB2\xCA\x39\x86\xD2\x68\x37\x05\x57\x7D\x45\xC2\xE7\xE5\x2D\xC8\x1C\x7A\x17\x18\x76\xE5\xCE\xA7\x4B\x14\x48\xBF\xDF\xAF\x18\x82\x8E\xFD\x25\x19\xF1\x4E\x45\xE3\x82\x66\x34\xAF\x19\x49\xE5\xB5\x35\xCC\x82\x9A\x48\x3B\x8A\x76\x22\x3E\x5D\x49\x0A\x25\x7F\x05\xBD\xFF\x16\xF2\xFB\x22\xC5\x83\xAB" -let g = "\x02" -let openid_param = { DH.p = modulus; DH.g = g; DH.privlen = 160 } - -let unpad s = - let rec loop acc k = - if k = String.length s - 1 then acc - else if s.[k] = '\000' && (s.[k+1] = '\000' || int_of_char s.[k+1] land 128 = 0) then - loop (acc + 1) (k + 1) - else - acc - in - let off = loop 0 0 in - String.sub s off (String.length s - off) -let encode_number message = - unpad (if int_of_char message.[0] land 128 <> 0 then - "\x00" ^ message - else message) - -let output_secret s = - let message = DH.message openid_param s in - Base64.encode (encode_number message) - -let gen_new_secret () = - DH.private_secret openid_param - -let gen_signature ~key ~args = - let kw = String.concat "" - (List.map (fun a -> Printf.sprintf "%s:%s\n" a (get args a)) - (Netstring_pcre.split (Netstring_pcre.regexp ",") (get args "signed"))) - in - hash_string (MAC.hmac_sha1 key) kw - -let check_signature ~key ~args = - let sig1 = Base64.encode (gen_signature ~key ~args) - and sig2 = get args "sig" - in - if sig1 <> sig2 then lwt_fail (Invalid_signature (sig1, sig2)) - else Lwt.return () - -let decode_number s = - if '\x00' = s.[0] then - String.sub s 1 (String.length s - 1) - else s - -let decrypt ~encrypted_mac ~secret ~pub_server = - let pub_server = decode_number pub_server in - let shared_secret = DH.shared_secret openid_param secret pub_server in - let shared_secret = unpad shared_secret in - let hzz = hash_string (Hash.sha1 ()) shared_secret in - let mac = String.make (String.length hzz) ' ' in - for k = 0 to String.length mac - 1 do - (int_of_char hzz.[k]) lxor (int_of_char encrypted_mac.[k]) - |> char_of_int - |> Bytes.set mac k - done; - mac - - -(* ASSOCIATION *) -(* This library only implements the stateful mode : - we first associate to the remote endpoint and store - the cryptographic data to be able to check the future signature ourselves *) -type assoctmp = { - t_mac : string; - t_assoc_handle : string; - t_delay : float; - t_secret : Cryptokit.DH.private_secret; - t_mac_crypted : string; - t_server_public : string; -} - -type assoc = { - mac : string; (* The crypting key *) - assoc_handle : string; (* The handle used by the server to remember us. *) - delay : float; (* The time by which the association will have expired *) -} -module M = Map.Make (struct type t = string let compare = compare end) -let associations = ref M.empty - -let associate endpoint = - let secret = gen_new_secret () in - let parse args = - let aux v (name, value) = - match name with - | "expires_in" -> { v with t_delay = float_of_string value +. Unix.time () } - | "enc_mac_key" -> { v with t_mac_crypted = Base64.decode value } - | "mac_key" -> { v with t_mac = Base64.decode value } - | "dh_server_public" -> { v with t_server_public = Base64.decode value } - | "assoc_handle" -> { v with t_assoc_handle = value } - | _ -> v - in - let assoc = List.fold_left aux { t_mac = ""; t_mac_crypted = ""; - t_assoc_handle = ""; t_delay = 0.; - t_secret = secret; - t_server_public = ""; } args in - if assoc.t_mac = "" && - (assoc.t_mac_crypted = "" || assoc.t_server_public = "") then - lwt_fail (Invalid_association endpoint) - else begin - let assoc = { - delay = assoc.t_delay; - mac = - (if assoc.t_mac <> "" then assoc.t_mac - else decrypt ~encrypted_mac:assoc.t_mac_crypted ~secret - ~pub_server: assoc.t_server_public); - assoc_handle = assoc.t_assoc_handle - } - in - Lwt_log.ign_warning_f ~section "Associated to `%s' (%s)" endpoint (Base64.encode assoc.mac); - Lwt.return assoc - end - in - direct_request - ~mode:"associate" - ~params: ["assoc_type", "HMAC-SHA1"; - "session_type", "DH-SHA1"; - "dh_consumer_public", output_secret secret] - ~endpoint >>= parse - -let get_assoc end_point = - try - return (M.find end_point !associations) - with Not_found -> - associate end_point >>= (fun v -> - associations := M.add end_point v !associations; - return v) - - -let reassociate end_point = - Lwt_log.ign_warning_f ~section "reassociating to %s" end_point; - associations := M.remove end_point !associations; - get_assoc end_point - - -(* CHECK *) -let scope = `Session (Eliom_common.create_scope_hierarchy "__eliom_openid") -let group_name = "__eliom_openid_group" - -type field = - | Email - | Fullname - | DateOfBirth - | PostCode - | Timezone - | Language - | Country - | Gender - | Nickname - -let field_names = [ - Email, "email"; - Fullname, "fullname"; - Nickname, "nickname"; - DateOfBirth, "dob"; - Gender, "gender"; - PostCode, "postcode"; - Country, "country"; - Language, "language"; - Timezone, "timezone"; -] -let field_names_rev = List.map (fun (x, y) -> (y, x)) field_names - -(* DEALING WITH EXTENSIONS *) -type 'b extension = { - headers: (string * string) list; - parse: (string * string) list -> 'b Lwt.t -} - -(* sreg extension - See http://openid.net/specs/openid-simple-registration-extension-1_0.html *) -let format_demands ~required ~required_name ~optional ~optional_name = - let get y = List.assoc y field_names in - let fmt l = String.concat "," (List.map get l) in - ((required <> []), (required_name, fmt required)) ^^? - ((optional <> []), (optional_name, fmt optional)) ^^? [] - -let sreg ?policy_url ~required ~optional () = - let li = format_demands ~required ~optional - ~required_name: "required" ~optional_name: "optional" - @ (Option.map (fun x -> "policy_url", x) policy_url ^? []) - in - let sreg_url = "http://openid.net/extensions/sreg/1.1" in - { - headers = ("ns.sreg", sreg_url) :: push_ns "sreg" li; - parse = (fun args -> - let args = find_in_ns ~default_namespace: "sreg" sreg_url args in - let args = List.map (fun (x, y) -> List.assoc x field_names_rev, y) args in - Lwt.return args) - } - -(* ax extension *) -let urls = - [ "type.email","http://axschema.org/contact/email"; - "type.nickname", "http://axschema.org/namePerson/friendly"; - "type.fullname", "http://axschema.org/namePerson"; - "type.dob", "http://axschema.org/birthDate"; - "type.gender", "http://axschema.org/person/gender"; - "type.postcode", "http://axschema.org/contact/postalCode/home"; - "type.country", "http://axschema.org/contact/country/home"; - "type.language", "http://axschema.org/pref/language"; - "type.timezone","http://axschema.org/pref/timezone" ] - - -let ax ~required ~optional () = - let url = "http://openid.net/srv/ax/1.0" in - let li = - let fields = required @ optional in - List.map (fun info -> - let name = "type."^List.assoc info field_names in - (name, List.assoc name urls)) fields - @ - format_demands ~required ~required_name:"required" - ~optional ~optional_name: "if_available" - in - { headers = ("ns.ax", url) :: push_ns "ax" (("mode", "fetch_request") :: li); - parse = (fun args -> - let args = find_in_ns ~default_namespace: "ax" url args in - let args = strip_ns "value" args in - let args = List.map (fun (x, y) -> List.assoc x field_names_rev, y) args in - Lwt.return args) - } - -(* PAPE *) -type pape = { auth_time : string option; policies : string list option; nist_level : int option } -let build_opt_list list = - List.fold_left (fun li -> function - | a, Some x -> (a, x) :: li - | _, None -> li) [] list - -let assoc_opt a l = try Some (List.assoc a l) with Not_found -> None -let pape ?max_auth_age ?auth_policies () = - let url = "http://specs.openid.net/extensions/pape/1.0" in - { - headers = - (build_opt_list - ["ns.pape", Some url; - "pape.max_auth_age", Option.map string_of_int max_auth_age; - "pape.preferred_auth_policies", Option.map (String.concat ",") auth_policies]); - parse = (fun args -> - let args = find_in_ns ~default_namespace: "pape" url args in - let auth_time = assoc_opt "auth_time" args in - let policies = Option.map (String.split ',') (assoc_opt "auth_policies" args) in - let nist_level = Option.map int_of_string (assoc_opt "nist_auth_level" args) in - Lwt.return - { auth_time = auth_time; policies = policies; - nist_level = nist_level }) - } - -let ( *** ) e1 e2 = { - headers = e1.headers @ e2.headers; - parse = (fun l -> e1.parse l >>= (fun a -> e2.parse l >>= (fun b -> return (a, b)))) -} - -(* CHECKING *) -let check_authentication ret_to endpoint assoc args = - check_arg args "return_to" ret_to - &&& check_signature assoc.mac args - -type 'a authentication_result = - | Canceled - | Setup_needed - | Result of 'a - -let end_login_handler ext ret_to endpoint assoc f args = - let args = strip_ns "openid" args in - let mode = get args "mode" in - let _ = Eliom_state.discard ~scope () in - if mode = "id_res" then - (if List.mem_assoc "invalidate_handle" args then - reassociate endpoint - else - Lwt.return assoc) >>= - (fun assoc -> check_authentication ret_to endpoint assoc args) >>= - (fun () -> ext.parse args) >>= (fun k -> f (Result k)) - else if mode = "cancel" then - f Canceled - else if mode = "setup_needed" then - f Setup_needed - else if mode = "error" then - lwt_fail (Server_error (get args "error")) - else - lwt_fail (Invalid_answer mode) - -module type HiddenServiceInfo = sig - - val path : string list - - val f : - (string * string) list -> - unit -> Eliom_registration.browser_content Eliom_registration.kind Lwt.t - -end - -module Make (S : HiddenServiceInfo) = struct - let return_service = - Eliom_service.create_unsafe - ~meth:(Eliom_service.Get any) - ~path:(Eliom_service.Path S.path) - () - - let () = Eliom_registration.Any.register ~service:return_service S.f - - let authenticate ~mode ~ext ~handler ~discovery = - let local = match snd discovery with - | None -> "http://specs.openid.net/auth/2.0/identifier_select" - | Some l -> l - in - get_assoc (fst discovery) >>= fun assoc -> - let uri = ref "" in - let () = uri := - Eliom_uri.make_string_uri ~absolute: true - ~service:return_service [] - in - let _ = Eliom_registration.Any.register - ~scope - ~service:return_service - (fun args _ -> - end_login_handler ext !uri (fst discovery) assoc handler args) - in - let _ = Eliom_state.set_service_session_group - ~set_max: 1000 - ~scope - group_name - in - let _ = Eliom_state.set_global_service_state_timeout - ~cookie_scope:scope - (Some 60.) - in - let params = - ["return_to", !uri; - "claimed_id", local; - "identity", local; - "assoc_handle", assoc.assoc_handle; - "realm", "http://"^Eliom_request_info.get_hostname ()] @ ext.headers - in - let params = push_ns "openid" (("ns", openid_url) :: ("mode", mode) :: params) in - Lwt.return (format_url (fst discovery) params) -end - -(* GLUE *) -type result = { - fields : (field * string) list; - pape : pape; -} - -let dispatch f = function - | Result (l, (l', pape)) -> - let r = { fields = l @ l'; pape = pape } in - f (Result r) - | (Canceled | Setup_needed) as x -> f x - - -let check = ref (fun ?mode ~ext ~handler ~discovery -> Lwt.fail (Failure "Call OpenID.init")) - -type check_fun = - ?immediate:bool -> - ?policy_url:string -> - ?max_auth_age:int -> - ?auth_policies:string list -> - ?required:field list -> - ?optional:field list -> - string -> - (result authentication_result -> - Eliom_registration.browser_content Eliom_registration.kind Lwt.t) -> - Url.t Lwt.t - -let check check ?(immediate = true) ?policy_url ?max_auth_age ?auth_policies - ?(required = []) ?(optional = []) user_url handler = - let mode = - if immediate then "checkid_immediate" - else "checkid_setup" - in - perform_discovery user_url >>= (fun discovery -> - check - ~mode - ~ext: (ax ~required ~optional () *** - sreg ?policy_url ~required ~optional () *** - pape ?max_auth_age ?auth_policies ()) - ~handler: (dispatch handler) - ~discovery) - -let init ~path ~f = - let module K = Make (struct let path = path let f = f end) in - check K.authenticate diff --git a/src/lib/server/extensions/eliom_openid.mli b/src/lib/server/extensions/eliom_openid.mli deleted file mode 100644 index eeadf2d778..0000000000 --- a/src/lib/server/extensions/eliom_openid.mli +++ /dev/null @@ -1,273 +0,0 @@ -(* Ocsigen - * Copyright (C) 2010 Simon Castellan - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, with linking exception; - * either version 2.1 of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - *) - -(** OpenID identification *) - -open Eliom_lib - -(** This module implements the Relying Party of the OpenID specification, - in stateful mode. *) - -(** {2 Library description} *) - -(** The library provides means to authenticate an user - to a remote provider using the OpenID protocol. - Basically, you need to ask the user its OpenID url, and - the fields you want to require (or none, if you just want to - authenticate an user), along with other information. - - The library uses an "hidden service" that is needed when the provider - redirects back to your site. This service is registered in the library, all you have - to do is to give a path for that service and a default handler - (if the user connects to that service without being in an authentication process.) - Here is a short example of how to use the library - {[ -open Eliom_openid -let messages = Eliom_state.create_volatile_table () -(* The login form *) -let login_form = Eliom_service.new_service - ~path:["login-form"] - ~get_params: Eliom_parameter.unit - () - -(* Initialize the library, and getting the authenticate function *) -let authenticate = Eliom_openid.init ~path:["__openid_return_service"] - ~f: (fun _ _ -> Eliom_registration.Redirection.send login_form) - -(* Create the handler for the form *) -(* We have to use Eliom_registration.String_redirection as we - redirect the user to her provider *) -let form_handler = Eliom_registration.String_redirection.register_new_post_coservice - ~fallback: login_form - ~post_params: (Eliom_parameter.string "url") - (fun _ url -> - authenticate - ~max_auth_age: 4 (* Requires that if the user logged in more that 4 seconds ago - he needs to relog in *) - ~required: [Eliom_openid.Email] (* Requires his e-mail *) - ~immediate: false - url - (fun result -> - let string = - match result with - | Setup_needed -> "setup needed" | Canceled -> "canceled" - | Result result -> - try List.assoc Email result.fields with Not_found -> "No e-mail :(" - in - Eliom_state.set_volatile_session_data ~table:messages string; - Eliom_registration.Redirection.send login_form)) - -open XHTML -let _ = Eliom_registration.Xhtml.register - ~service: login_form - (fun _ _ -> - (match Eliom_state.get_volatile_session_data ~table: messages () with - | Eliom_state.Data s -> - Eliom_state.discard () >>= fun () -> - Lwt.return [p [pcdata ("Authentication result: "^ s)]] - | _ -> Lwt.return []) >>= fun message -> - let form = - Eliom_registration.Xhtml.post_form ~service:form_handler - (fun url -> - [p [pcdata "Your OpenID identifier: "; - Eliom_registration.Xhtml.string_input ~input_type:`Text ~name:url (); - Eliom_registration.Xhtml.string_input ~input_type:`Submit ~value:"Login" (); - ]]) () - in - Lwt.return - (html - (head (title (pcdata "A sample test")) []) - (body - (message @ [form])))) -]} -*) - -(** {2 Documentation} *) - -(** {3 Miscallenous} *) - -(** Error that may happen when identifiying an user *) -type openid_error = - Invalid_XRDS_File of string * string - (** The provider XRDS file was not valid *) - | Discovery_Error of string * string - (** An error occured during the discovery of the provider *) - | Missing_parameter of string - (** The remote server forgot a parameter in its request *) - | Invalid_signature of string * string - (** We disagree with the server's signature *) - | Invalid_association of string - (** We were unable to associate with a provider *) - | Invalid_argument of string * string * string - (** The argument provided were not set to a correct value *) - | Server_error of string - (** The server threw an explicit error *) - | Invalid_answer of string - (** The answer code was not correct *) - | Invalid_html_doc of string - (** An error occured during the parsing of an user url in html format *) - -(** Prettyprint an OpenID Error *) -val string_of_openid_error : openid_error -> string - -(** Exception thrown by this module's function. *) -exception Error of openid_error - -(** A field you can request to the provider *) -type field = - Email - | Fullname - | DateOfBirth - | PostCode - | Timezone - | Language - | Country - | Gender - | Nickname - -(** An extension yielding values of type 'a *) -type 'a extension = { - headers : (string * string) list; - parse : (string * string) list -> 'a Lwt.t; -} - -(** The SREG extension - @see SREG *) -val sreg : - ?policy_url:string -> - required:field list -> - optional:field list -> unit -> (field * string) list extension - -(** The AX extension - @see AX*) -val ax : - required:field list -> - optional:field list -> unit -> (field * string) list extension - -(** The pape data returned by the server *) -type pape = { - auth_time : string option; - (** The time at which the user last logged in *) - policies : string list option; - (** A list of policies (url) describing your usage of the data *) - nist_level : int option; - (** The nist level *) -} -val pape : - ?max_auth_age:int -> ?auth_policies:string list -> unit -> pape extension -(** The PAPE extension. - @see PAPE *) - -val ( *** ) : 'a extension -> 'b extension -> ('a * 'b) extension -(** Product of two extension *) - -(** The result of an authentication. *) -type 'a authentication_result = - Canceled (** The user canceled the login (or failed) *) - | Setup_needed (** The provider has not enough information to complete an immediate - request. Only returned when using an immediate authentication. *) - | Result of 'a (** All went ok. *) - - -(** {3 Low-level interface.} *) - -(** Perform discovery on an user-supplied url *) -val perform_discovery : string -> (string * string option) Lwt.t - - -(** Information about the hidden service *) -module type HiddenServiceInfo = sig - - (** The path of the hidden service *) - val path : string list - - (** The function called when an user connects to the hidden service - (not that hidden) without being in an identication process. - Typically you should redirect the user to the login page. *) - val f : - (string * string) list -> - unit -> Eliom_registration.browser_content Eliom_registration.kind Lwt.t - -end - -(** This functor build a hidden service that will be used to receive - the remote server's data. In return you get a check function *) -module Make : - functor - (S : HiddenServiceInfo) -> - sig - val authenticate : - mode:string -> - ext:'a extension -> - handler:('a authentication_result -> - Eliom_registration.browser_content Eliom_registration.kind Lwt.t) -> - discovery:string * string option -> Url.t Lwt.t - (** Authenticate an user. - - mode: can be [checkid_setup] or [checkid_immediate] - whether you want immediate identification or not. - - ext: the extensions you want to use. - - handler: the handler called with the result of the authentication. - - discovery: The discovery information - In return you get an URI you have to redirect the user to. *) - end - -(** {3 High-level interface} *) -(** The high-level interface takes care of creating - the extension you want, without to use them directly. - It yields a [result]. *) - -(** The result yielded by the authentication process *) -type result = { - fields : (field * string) list; - (** The fields you requested *) - pape : pape; - (** The pape information *) -} - -(** The type of the authenticate function. - - immediate: whether to use immediate identification or not (default: true) - - policy_url: an optional policy url to describe what you do with the data (sreg) (default:none) - - required: optional fields you really need (although the provier may not provide them) (default:empty) - - optional: optional fields you don't really need (default: empty) - - max_auth_age: Requires that the user logged in less than [n] seconds ago. (default: up to the provider) - - auth_policies: A list of url describing your policies regarding the data (default: empty) - - the url the user gave you - - an handler, that'll be called after checking the parameters with the result - and the server params of the GET request. You can send whatever page you want - but you should redirect the user to a page so he can't bookmark it, or - send some piece of html to interface with javascript. -*) -type check_fun = - ?immediate:bool -> - ?policy_url:string -> - ?max_auth_age:int -> - ?auth_policies:string list -> - ?required:field list -> - ?optional:field list -> - string -> - (result authentication_result -> - Eliom_registration.browser_content Eliom_registration.kind Lwt.t) -> - Url.t Lwt.t - -(** Init the OpenID for your site. - Takes a path and a handler for the hidden service *) -val init : - path:string list -> - f:((string * string) list -> unit -> - Eliom_registration.browser_content Eliom_registration.kind Lwt.t) -> - check_fun diff --git a/src/lib/server/extensions/eliom_s2s.ml b/src/lib/server/extensions/eliom_s2s.ml deleted file mode 100644 index c1e9938716..0000000000 --- a/src/lib/server/extensions/eliom_s2s.ml +++ /dev/null @@ -1,117 +0,0 @@ -(* Ocsigen - * Copyright (C) 2010 Simon Castellan - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, with linking exception; - * either version 2.1 of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - *) -(* Server To Server communication *) - -open Eliom_lib - -open Lwt -open Ocsigen_stream -open Ocsigen_http_frame - -let filter_map f l = - List.fold_left (fun l t -> match f t with - | Some t' -> t' :: l - | None -> l) [] l - -let rec find_map f = function - | [] -> raise Not_found - | t :: q -> match f t with - | Some x -> x - | None -> find_map f q - -let strip ?(sep = '.') v s = try - let start, rest = String.basic_sep sep s in - if start = v then Some rest - else None - with Not_found -> None - -let strip2 ?sep v (name, value) = - Option.map (fun y -> y, value) (strip ?sep v name) - - -(* Parameters *) -let format_url base params = base ^ "?" ^ Netencoding.Url.mk_url_encoded_parameters params -let push_ns ?(sep = ".") ?namespace_param namespace params = - List.map (fun (name, value) -> String.may_append namespace ~sep name, value) - (match namespace_param with - | Some a -> a :: params - | None -> params) - -let strip_ns namespace params = filter_map (strip2 namespace) params -let find_in_ns ?(namespace_param = "ns") ?default_namespace url params = - let ns = - try - let (name, _) = List.find (fun (_, value) -> value = url) params in - match strip namespace_param name with - | Some namespace -> namespace - | None -> raise Not_found - with Not_found -> (match default_namespace with - | Some x -> x - | None -> raise Not_found) - in - filter_map (strip2 ns) params - - -(* Request *) -let rec do_request f uri = - let url = Neturl.parse_url uri in - let host, https = Neturl.url_host url, Neturl.url_scheme url = "https" in - f ~host ~https ~uri >>= - (fun frame -> - (* Follow redirection *) - match frame.frame_header.Http_header.mode with - | Http_header.Answer 301 | Http_header.Answer 302 - | Http_header.Answer 303 | Http_header.Answer 307 -> - let uri = Ocsigen_http_frame.Http_header.get_headers_value frame.frame_header - Http_headers.location in - do_request f uri - | _ -> Lwt.return frame) - - -let do_post_request params = - do_request - (fun ~host ~https ~uri -> - Ocsigen_http_client.post_string ~host ~https ~uri - ~content_type:("application", "x-www-form-urlencoded") - ~content: (Netencoding.Url.mk_url_encoded_parameters params) ()) - -let do_get_request ?(params=[]) = - do_request (fun ~host ~https ~uri -> - let uri = - if params = [] then uri - else format_url uri params - in - Ocsigen_http_client.get ~host ~https ~uri ()) - - -let get_frame_content frame = - match frame.frame_content with - | Some st -> string_of_stream 1000000 (get st) - | None -> Lwt.return "" - -(* Parsing body answers *) -let parse_key_pairs contents = - let parse_line values s = - try Scanf.sscanf s "%[^:]: %[^\n]" (fun a b -> (a, b) :: values) - with _ -> values - in - let lines = Netstring_pcre.split (Netstring_pcre.regexp "\n") contents in - List.fold_left parse_line [] lines -let direct_request params endpoint = - do_post_request params endpoint >>= - get_frame_content >>= (fun s -> return (parse_key_pairs s)) diff --git a/src/lib/server/extensions/eliom_s2s.mli b/src/lib/server/extensions/eliom_s2s.mli deleted file mode 100644 index e1c1b07377..0000000000 --- a/src/lib/server/extensions/eliom_s2s.mli +++ /dev/null @@ -1,53 +0,0 @@ -(* Ocsigen - * Copyright (C) 2010 Simon Castellan - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, with linking exception; - * either version 2.1 of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - *) - -(** Server-to-Server communication module. - Provides general function to communicate to other servers using - post or get request. *) - -(** Format a url with a base and GET parameters *) -val format_url : string -> (string * string) list -> string - -(** Do a get request towards a given url *) -val do_get_request : ?params : (string * string) list -> string -> Ocsigen_http_frame.t Lwt.t - -(** Given a list of [(param, value)] to be sent to the remote server, - push a namespace at the beginning of the parameters *) -val push_ns : - ?sep:string -> - ?namespace_param:string * 'a -> - string -> (string * 'a) list -> (string * 'a) list - -(** Finds some parameters in a namespace, identified by its url. - You can specify a default namespace, so [find_in_ns] do not fail - when the url is not found. *) -val find_in_ns : - ?namespace_param:string -> - ?default_namespace:string -> 'a -> (string * 'a) list -> (string * 'a) list - -(** Retrieves parameters beginning with the specified namespace and - strips it. *) -val strip_ns : string -> (string * string) list -> (string * string) list - -(** Parse an answer in the Key-Value form : - {v foo:bar foobar:value v} *) -val parse_key_pairs : string -> (string * string) list - -(** Perform a direct (POST) request towards a server, - and parse the result as key-value data *) -val direct_request : (string * string) list -> string -> (string * string) list Lwt.t