1/* Part of SWI-Prolog 2 3 Author: Jan Wielemaker 4 E-mail: J.Wielemaker@vu.nl 5 WWW: http://www.swi-prolog.org 6 Copyright (c) 2008-2012, University of Amsterdam 7 All rights reserved. 8 9 Redistribution and use in source and binary forms, with or without 10 modification, are permitted provided that the following conditions 11 are met: 12 13 1. Redistributions of source code must retain the above copyright 14 notice, this list of conditions and the following disclaimer. 15 16 2. Redistributions in binary form must reproduce the above copyright 17 notice, this list of conditions and the following disclaimer in 18 the documentation and/or other materials provided with the 19 distribution. 20 21 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22 "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23 LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 24 FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 25 COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 26 INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 27 BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 28 LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 29 CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 30 LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 31 ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 32 POSSIBILITY OF SUCH DAMAGE. 33*/ 34 35:- module(doc_access, 36 [ host_access_options/2 % +AllOptions, -NoAccessOptions 37 ]). 38:- use_module(library(http/http_hook)). 39:- use_module(library(dcg/basics)). 40 41:- dynamic 42 can_edit/1, 43 allow_from/1, 44 deny_from/1. 45 46:- meta_predicate 47 match_peer(, , ). 48 49% http:authenticate(+Type, +Request, -Extra) is semidet. 50% 51% PlDoc specific access control. The access control is based on 52% these options that are passed from starting PlDoc. If PlDoc runs 53% on top of an external dispatch loop, the predicate 54% host_access_options/2 can be used to specify access rights. 55% 56% * allow(+IP) 57% * deny(+IP) 58% * edit(+Bool) 59 60httpauthenticate(pldoc(read), Request, []) :- 61 !, 62 memberchk(peer(Peer), Request), 63 allowed_peer(Peer). 64httpauthenticate(pldoc(edit), Request, []) :- 65 !, 66 ( can_edit(false) 67 -> fail 68 ; ( memberchk(x_forwarded_for(Forwarded), Request), 69 primary_forwarded_host(Forwarded, IPAtom), 70 parse_ip(IPAtom, Peer) 71 -> true 72 ; memberchk(peer(Peer), Request) 73 ), 74 match_peer(localhost, +, Peer) 75 ). 76 77 78%! host_access_options(+AllOptions, -NoAuthOptions) is det. 79% 80% Filter the authorization options from AllOptions, leaving the 81% remaining options in NoAuthOptions. 82 83host_access_options([], []). 84host_access_options([H|T0], T) :- 85 host_access_option(H), 86 !, 87 host_access_options(T0, T). 88host_access_options([H|T0], [H|T]) :- 89 host_access_options(T0, T). 90 91host_access_option(allow(From)) :- 92 assert(allow_from(From)). 93host_access_option(deny(From)) :- 94 assert(deny_from(From)). 95host_access_option(edit(Bool)) :- 96 assert(can_edit(Bool)). 97 98%! match_peer(:RuleSet, +PlusMin, +Peer) is semidet. 99% 100% True if Peer is covered by the ruleset RuleSet. Peer is a term 101% ip(A,B,C,D). RuleSet is a predicate with one argument that is 102% either a partial ip term, a hostname or a domainname. 103% Domainnames start with a '.'. 104% 105% @param PlusMin Positive/negative test. If IP->Host fails, a 106% positive test fails, while a negative succeeds. 107% I.e. deny('.com') succeeds for unknown IP 108% addresses. 109 110match_peer(Spec, _, Peer) :- 111 call(Spec, Peer), 112 !. 113match_peer(Spec, PM, Peer) :- 114 ( call(Spec, HOrDom), atom(HOrDom) 115 -> ( catch(tcp_host_to_address(Host, Peer), E, true), 116 var(E) 117 -> call(Spec, HostOrDomain), 118 atom(HostOrDomain), 119 ( sub_atom(HostOrDomain, 0, _, _, '.') 120 -> sub_atom(Host, _, _, 0, HostOrDomain) 121 ; HostOrDomain == Host 122 ) 123 ; PM == (+) 124 -> !, fail 125 ; true 126 ) 127 ). 128 129%! allowed_peer(+Peer) is semidet. 130% 131% True if Peer is allowed according to the rules. 132 133allowed_peer(Peer) :- 134 match_peer(deny_from, -, Peer), 135 !, 136 match_peer(allow_from, +, Peer). 137allowed_peer(Peer) :- 138 allow_from(_), 139 !, 140 match_peer(allow_from, +, Peer). 141allowed_peer(_). 142 143 144:- dynamic 145 can_edit/1. 146 147%! primary_forwarded_host(+Spec, -Host) is det. 148% 149% x_forwarded host contains multiple hosts separated by ', ' if 150% there are multiple proxy servers in between. The first one is 151% the one the user's browser knows about. 152 153primary_forwarded_host(Spec, Host) :- 154 sub_atom(Spec, B, _, _, ','), 155 !, 156 sub_atom(Spec, 0, B, _, Host). 157primary_forwarded_host(Host, Host). 158 159 160localhost(ip(127,0,0,1)). 161localhost(localhost). 162 163parse_ip(Atom, IP) :- 164 atom_codes(Atom, Codes), 165 phrase(ip(IP), Codes). 166 167%! ip(?IP)// is semidet. 168% 169% Parses A.B.C.D into ip(A,B,C,D) 170 171ip(ip(A,B,C,D)) --> 172 integer(A), ".", integer(B), ".", integer(C), ".", integer(D)