1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
|
(* Ocsigen
* http://www.ocsigen.org
* Module authbasic.ml
* Copyright (C) 2008 Stéphane Glondu
* Laboratoire PPS - CNRS Université Paris Diderot
*
* 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 Printf
open Lwt
open Ocsigen_extensions
open Simplexmlparser
open Ocsigen_http_frame
(*****************************************************************************)
(* Management of basic authentication methods *)
exception Bad_config_tag_for_auth of string
let register_basic_authentication_method, get_basic_authentication_method =
let fun_auth = ref
(fun config ->
raise (Bad_config_tag_for_auth "<unknown basic authentication method>"))
in
(********* register_basic_authentication_method *********)
(fun new_fun_auth ->
let old_fun_auth = !fun_auth in
fun_auth :=
(fun config ->
try
old_fun_auth config
with
| Bad_config_tag_for_auth c -> new_fun_auth config)),
(********* get_basic_authentication_method *********)
(fun config ->
!fun_auth config)
(*****************************************************************************)
(* Basic authentication with a predefined login/password (example) *)
let _ = register_basic_authentication_method
(function
| Element ("plain", ["login", login; "password", password], _) ->
(fun l p -> Lwt.return (login = l && password = p))
| _ -> raise (Bad_config_tag_for_extension "not for htpasswd"))
(*****************************************************************************)
let parse_config = function
| Element ("authbasic", ["realm", realm], auth::[]) ->
(* http://www.ietf.org/rfc/rfc2617.txt *)
(* TODO: check that realm is correct *)
let auth =
try
get_basic_authentication_method auth
with Bad_config_tag_for_extension _ ->
raise (Error_in_config_file "Unable to find proper authentication method")
in
(fun rs ->
match rs with
| Ocsigen_extensions.Req_not_found (err, ri) ->
let reject () =
let h = Http_headers.add
(Http_headers.name "WWW-Authenticate")
(sprintf "Basic realm=\"%s\"" realm)
Http_headers.empty
in
Ocsigen_messages.debug2 "--Access control (auth): invalid credentials!";
fail (Http_error.Http_exception (401, None, Some h))
in
begin try
let (login, password) =
let credentials =
Http_headers.find
(Http_headers.name "Authorization")
ri.request_info.ri_http_frame.Ocsigen_http_frame.frame_header.Ocsigen_http_frame.Http_header.headers
in
let encoded =
let n = String.length credentials in
if n > 6 && String.sub credentials 0 6 = "Basic " then
String.sub credentials 6 (n-6)
else
failwith "credentials"
in
let decoded = Netencoding.Base64.decode encoded in
let i = String.index decoded ':' in
(String.sub decoded 0 i,
String.sub decoded (i+1) (String.length decoded - (i+1)))
in
auth login password >>=
(fun r ->
if r then begin
Ocsigen_messages.debug2 "--Access control (auth): valid credentials!";
Lwt.return (Ocsigen_extensions.Ext_next err)
end
else reject ())
with
| Not_found -> reject ()
| e ->
Ocsigen_messages.debug
(fun () -> sprintf
"--Access control (auth): Invalid Authorization header (%s)"
(Printexc.to_string e));
fail (Ocsigen_http_error (Ocsigen_http_frame.Cookies.empty, 400))
end
| Ocsigen_extensions.Req_found (ri, r) ->
Lwt.return Ocsigen_extensions.Ext_do_nothing)
| Element ("authbasic" as s, _, _) -> badconfig "Bad syntax for tag %s" s
| Element (t, _, _) -> raise (Bad_config_tag_for_extension t)
| _ -> raise (Error_in_config_file "(authbasic extension) Bad data")
(*****************************************************************************)
(** Registration of the extension *)
let () = register_extension
~name:"authbasic"
~fun_site:(fun _ _ _ _ -> parse_config)
~user_fun_site:(fun _ _ _ _ _ -> parse_config)
()
|
