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(1, +, +).
  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
  60http:authenticate(pldoc(read), Request, []) :-
  61    !,
  62    memberchk(peer(Peer), Request),
  63    allowed_peer(Peer).
  64http:authenticate(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 seperated   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).