test-lib.pm 9.49 KB
Newer Older
Yadd's avatar
Yadd committed
1
# Base library for portal tests
Yadd's avatar
Yadd committed
2
package main;
Yadd's avatar
Yadd committed
3
4
5

use strict;
use Data::Dumper;
Yadd's avatar
Yadd committed
6
use LWP::UserAgent;
Yadd's avatar
Yadd committed
7
use URI::Escape;
Yadd's avatar
Yadd committed
8
use 5.10.0;
Yadd's avatar
Yadd committed
9

Yadd's avatar
Yadd committed
10
11
no warnings 'redefine';

Yadd's avatar
Yadd committed
12
13
14
15
BEGIN {
    use_ok('Lemonldap::NG::Portal::Main');
}

Yadd's avatar
Yadd committed
16
our $count = 1;
Yadd's avatar
Yadd committed
17
$Data::Dumper::Deparse = 1;
Yadd's avatar
Yadd committed
18
my $ini;
Yadd's avatar
Yadd committed
19
20
21
22
23
24
25

sub count {
    my $c = shift;
    $count += $c if ($c);
    return $count;
}

Yadd's avatar
Yadd committed
26
sub main::explain {
Yadd's avatar
Yadd committed
27
28
29
30
31
    my ( $get, $ref ) = @_;
    $get = Dumper($get) if ( ref $get );
    print STDERR "Expect $ref, get $get\n";
}

Yadd's avatar
Yadd committed
32
33
34
35
36
sub clean_sessions {
    opendir D, 't/sessions' or die $!;
    foreach ( grep { /^[^\.]/ } readdir(D) ) {
        unlink "t/sessions/$_", "t/sessions/lock/Apache-Session-$_.lock";
    }
Yadd's avatar
Yadd committed
37
38
39
40
41
42
43
    foreach my $dir (qw(t/sessions/lock t/sessions/saml/lock t/sessions/saml)) {
        if ( -d $dir ) {
            opendir D, $dir or die $!;
            foreach ( grep { /^[^\.]/ } readdir(D) ) {
                unlink "$dir/$_";
            }
        }
Yadd's avatar
Yadd committed
44
45
46
    }
}

Yadd's avatar
Yadd committed
47
48
sub expectRedirection {
    my ( $res, $location ) = @_;
Yadd's avatar
Yadd committed
49
    ok( $res->[0] == 302, ' Get redirection' )
Yadd's avatar
Yadd committed
50
      or explain( $res->[0], 302 );
Yadd's avatar
Yadd committed
51
    count(1);
Yadd's avatar
Yadd committed
52
53
54
    if ( ref $location ) {
        my @match;
        @match = ( getRedirection($res) =~ $location );
Yadd's avatar
Yadd committed
55
        ok( @match, ' Location header found' )
Yadd's avatar
Yadd committed
56
          or explain( $res->[1], "Location match: " . Dumper($location) );
Yadd's avatar
Yadd committed
57
        count(1);
Yadd's avatar
Yadd committed
58
59
60
        return @match;
    }
    else {
Yadd's avatar
Yadd committed
61
        ok( getRedirection($res) eq $location, " Location is $location" )
Yadd's avatar
Yadd committed
62
          or explain( $res->[1], "Location => $location" );
Yadd's avatar
Yadd committed
63
count(1);
Yadd's avatar
Yadd committed
64
65
66
    }
}

Yadd's avatar
Yadd committed
67
sub expectAutoPost {
Yadd's avatar
Yadd committed
68
69
    my @r = expectForm(@_);
    my $method = pop @r;
Yadd's avatar
Yadd committed
70
    ok ( $method =~ /^post$/i, ' Method is POST' ) or explain (\@r,'POST');
Yadd's avatar
Yadd committed
71
    count(1);
Yadd's avatar
Yadd committed
72
    return @r;
Yadd's avatar
Yadd committed
73
74
75
}

sub expectForm {
Yadd's avatar
Yadd committed
76
77
    my ( $res, $hostRe, $uriRe, @requiredFields ) = @_;
    expectOK($res);
Yadd's avatar
Yadd committed
78
    count(1);
Yadd's avatar
Yadd committed
79
80
81
    if (
        ok(
            $res->[2]->[0] =~
Yadd's avatar
Yadd committed
82
              m@<form.+?action="(?:http://([^/]+)(/.*?)?|(#))".+method="(post|get)"@is,
Yadd's avatar
Yadd committed
83
            ' Page contains a form'
Yadd's avatar
Yadd committed
84
85
86
        )
      )
    {
Yadd's avatar
Yadd committed
87
88
89
90
91
        my ( $host, $uri, $hash, $method ) = ( $1, $2, $3, $4 );
        if($hash and $hash eq '#') {
            $host = '#';
            $uri = '';
        }
Yadd's avatar
Yadd committed
92
93
        if ($hostRe) {
            if ( ref $hostRe ) {
Yadd's avatar
Yadd committed
94
                ok( $host =~ $hostRe, ' Host match' )
Yadd's avatar
Yadd committed
95
96
97
                  or explain( $host, $hostRe );
            }
            else {
Yadd's avatar
Yadd committed
98
                ok( $host eq $hostRe, ' Host match' )
Yadd's avatar
Yadd committed
99
100
101
102
103
104
                  or explain( $host, $hostRe );
            }
            count(1);
        }
        if ($uriRe) {
            if ( ref $uriRe ) {
Yadd's avatar
Yadd committed
105
                ok( $uri =~ $uriRe, ' URI match' ) or explain( $uri, $uriRe );
Yadd's avatar
Yadd committed
106
107
            }
            else {
Yadd's avatar
Yadd committed
108
                ok( $uri eq $uriRe, ' URI match' ) or explain( $uri, $uriRe );
Yadd's avatar
Yadd committed
109
110
111
112
            }
            count(1);
        }
        my %fields = ( $res->[2]->[0] =~
Yadd's avatar
Yadd committed
113
              m#<input.+?name="(.+?)".+?value="(.+?)"#gs );
Yadd's avatar
Yadd committed
114
115
116
117
        my $query = join( '&',
            map { "$_=" . uri_escape( uri_unescape( $fields{$_} ) ) }
              keys(%fields) );
        foreach my $f (@requiredFields) {
Yadd's avatar
Yadd committed
118
            ok( defined $fields{$f}, qq{ Field "$f" is defined} );
Yadd's avatar
Yadd committed
119
120
            count(1);
        }
Yadd's avatar
Yadd committed
121
        return ( $host, $uri, $query, $method );
Yadd's avatar
Yadd committed
122
123
124
125
126
127
    }
    else {
        return ();
    }
}

Yadd's avatar
Yadd committed
128
129
sub expectAuthenticatedAs {
    my ( $res, $user ) = @_;
Yadd's avatar
Yadd committed
130
    ok( getHeader( $res, 'Lm-Remote-User' ) eq $user, " Authenticated as $user" )
Yadd's avatar
Yadd committed
131
132
133
134
135
136
      or explain( $res->[1], "Lm-Remote-User => $user" );
    count(1);
}

sub expectOK {
    my ($res) = @_;
Yadd's avatar
Yadd committed
137
    ok( $res->[0] == 200, ' HTTP code is 200' ) or explain( $res, 200 );
Yadd's avatar
Yadd committed
138
139
140
141
142
    count(1);
}

sub expectBadRequest {
    my ($res) = @_;
Yadd's avatar
Yadd committed
143
    ok( $res->[0] == 400, ' HTTP code is 400' ) or explain( $res->[0], 400 );
Yadd's avatar
Yadd committed
144
145
146
147
148
    count(1);
}

sub expectReject {
    my ($res) = @_;
Yadd's avatar
Yadd committed
149
    ok( $res->[0] == 401, ' Response is 401' ) or explain( $res->[0], 401 );
Yadd's avatar
Yadd committed
150
151
152
153
154
155
156
157
    count(1);
}

sub expectCookie {
    my ( $res, $cookieName ) = @_;
    $cookieName ||= 'lemonldap';
    my $cookies = getCookies($res);
    my $id;
Yadd's avatar
Yadd committed
158
    ok( defined( $id = $cookies->{$cookieName} ), " Get cookie $cookieName" )
Yadd's avatar
Yadd committed
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
      or explain( $res->[1], "Set-Cookie: $cookieName=something" );
    count(1);
    return $id;
}

sub getCookies {
    my ($resp) = @_;
    my @hdrs   = @{ $resp->[1] };
    my $res    = {};
    while ( my $name = shift @hdrs ) {
        my $v = shift @hdrs;
        if ( $name eq 'Set-Cookie' ) {
            if ( $v =~ /^(\w+)=([^;]*)/ ) {
                $res->{$1} = $2;
            }
        }
    }
    return $res;
}

sub getHeader {
    my ( $resp, $hname ) = @_;
    my @hdrs = @{ $resp->[1] };
    my $res  = {};
    while ( my $name = shift @hdrs ) {
        my $v = shift @hdrs;
        if ( $name eq $hname ) {
            return $v;
        }
    }
    return undef;
}

sub getRedirection {
    my ($resp) = @_;
    return getHeader( $resp, 'Location' );
}

sub getUser {
    my ($resp) = @_;
    return getHeader( $resp, 'Lm-Remote-User' );
}

Yadd's avatar
Yadd committed
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
package LLNG::Manager::Test;

use strict;
use Mouse;

extends 'Lemonldap::NG::Common::PSGI::Cli::Lib';

our $defaultIni = {
    configStorage       => { type => 'File', dirName => 't' },
    localSessionStorage => '',
    logLevel            => 'error',
    cookieName          => 'lemonldap',
    domain              => 'example.com',
    templateDir         => 'site/templates',
    staticPrefix        => '/index.fcgi',
    securedCookie       => 0,
    https               => 0,
};

has app => (
222
223
    is  => 'rw',
    isa => 'CodeRef',
Yadd's avatar
Yadd committed
224
225
);

Yadd's avatar
Yadd committed
226
227
has p => ( is => 'rw' );

228
229
230
231
232
233
234
235
236
has ini => (
    is      => 'rw',
    default => sub { $defaultIni; },
    trigger => sub {
        my ( $self, $ini ) = @_;
        foreach my $k ( keys %$defaultIni ) {
            $ini->{$k} //= $defaultIni->{$k};
        }
        $self->{ini} = $ini;
Yadd's avatar
Yadd committed
237
238
239
        main::ok($self->{p} = Lemonldap::NG::Portal::Main->new(),'Portal object');
        main::ok($self->{p}->init($ini),'Init');
        main::ok( $self->{app} = $self->{p}->run(),
240
            'Portal app' );
Yadd's avatar
Yadd committed
241
        main::count(3);
242
        $self;
Yadd's avatar
Yadd committed
243
244
245
    }
);

Yadd's avatar
Yadd committed
246
sub logout {
247
    my ( $self, $id ) = @_;
Yadd's avatar
Yadd committed
248
    my $res;
Yadd's avatar
Yadd committed
249
250
    main::ok(
        $res = $self->_get(
Yadd's avatar
Yadd committed
251
252
253
254
255
            '/',
            query  => 'logout',
            cookie => "lemonldap=$id",
            accept => 'text/html'
        ),
Yadd's avatar
Yadd committed
256
        'Logout request'
Yadd's avatar
Yadd committed
257
    );
258
259
    main::ok( $res->[0] == 200, 'Response is 200' )
      or explain( $res->[0], 200 );
260
    my $c;
261
    main::ok(
Yadd's avatar
Yadd committed
262
        ( defined( $c = main::getCookies($res)->{lemonldap} ) and not $c ),
263
264
        'Cookie is deleted' )
      or explain( $res->[1], "Set-Cookie => 'lemonldap='" );
Yadd's avatar
Yadd committed
265
    main::ok( $res = $self->_get( '/', cookie => "lemonldap=$id" ),
266
267
        'Disconnect request' )
      or explain( $res, '[<code>,<hdrs>,<content>]' );
Yadd's avatar
Yadd committed
268
269
    main::ok( $res->[0] == 401, 'Response is 401' ) or explain( $res, 401 );
    main::count(5);
Yadd's avatar
Yadd committed
270
271
272

}

Yadd's avatar
Yadd committed
273
274
275
276
277
278
279
sub _get {
    my ( $self, $path, %args ) = @_;
    return $self->app->(
        {
            'HTTP_ACCEPT' => $args{accept}
              || 'application/json, text/plain, */*',
            'HTTP_ACCEPT_LANGUAGE' => 'fr,fr-FR;q=0.8,en-US;q=0.5,en;q=0.3',
Yadd's avatar
Yadd committed
280
            'HTTP_CACHE_CONTROL'   => 'max-age=0',
Yadd's avatar
Yadd committed
281
            ( $args{cookie} ? ( HTTP_COOKIE => $args{cookie} ) : () ),
Yadd's avatar
Yadd committed
282
283
284
            'HTTP_HOST' => 'auth.example.com',
            'HTTP_USER_AGENT' =>
              'Mozilla/5.0 (VAX-4000; rv:36.0) Gecko/20350101 Firefox',
Yadd's avatar
Yadd committed
285
286
            'PATH_INFO' => $path,
            ( $args{referer} ? ( REFERER => $args{referer} ) : () ),
Yadd's avatar
Yadd committed
287
288
289
290
291
292
            'REMOTE_ADDR' => '127.0.0.1',
            (
                $args{remote_user}
                ? ( 'REMOTE_USER' => $args{remote_user} )
                : ()
            ),
Yadd's avatar
Yadd committed
293
            'REQUEST_METHOD' => 'GET',
Yadd's avatar
Yadd committed
294
            'REQUEST_URI'    => $path . ( $args{query} ? "?$args{query}" : '' ),
Yadd's avatar
Yadd committed
295
            ( $args{query} ? ( QUERY_STRING => $args{query} ) : () ),
Yadd's avatar
Yadd committed
296
297
            'SCRIPT_NAME'     => '',
            'SERVER_NAME'     => 'auth.example.com',
Yadd's avatar
Yadd committed
298
            'SERVER_PORT'     => '80',
Yadd's avatar
Yadd committed
299
            'SERVER_PROTOCOL' => 'HTTP/1.1',
Yadd's avatar
Yadd committed
300
            ( $args{custom} ? %{ $args{custom} } : () ),
Yadd's avatar
Yadd committed
301
302
303
304
        }
    );
}

Yadd's avatar
Yadd committed
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
sub _post {
    my ( $self, $path, $body, %args ) = @_;
    die "$body must be a IO::Handle"
      unless ( ref($body) and $body->can('read') );
    return $self->app->(
        {
            'HTTP_ACCEPT' => $args{accept}
              || 'application/json, text/plain, */*',
            'HTTP_ACCEPT_LANGUAGE' => 'fr,fr-FR;q=0.8,en-US;q=0.5,en;q=0.3',
            'HTTP_CACHE_CONTROL'   => 'max-age=0',
            ( $args{cookie} ? ( HTTP_COOKIE => $args{cookie} ) : () ),
            'HTTP_HOST' => 'auth.example.com',
            'HTTP_USER_AGENT' =>
              'Mozilla/5.0 (VAX-4000; rv:36.0) Gecko/20350101 Firefox',
            'PATH_INFO' => $path,
320
321
            ( $args{query}   ? ( QUERY_STRING => $args{query} )   : () ),
            ( $args{referer} ? ( REFERER      => $args{referer} ) : () ),
Yadd's avatar
Yadd committed
322
323
324
325
326
327
328
329
            'REMOTE_ADDR' => '127.0.0.1',
            (
                $args{remote_user}
                ? ( 'REMOTE_USER' => $args{remote_user} )
                : ()
            ),
            'REQUEST_METHOD' => 'POST',
            'REQUEST_URI'    => $path . ( $args{query} ? "?$args{query}" : '' ),
330
331
            'SCRIPT_NAME'    => '',
            'SERVER_NAME'    => 'auth.example.com',
Yadd's avatar
Yadd committed
332
            'SERVER_PORT'    => '80',
Yadd's avatar
Yadd committed
333
334
335
336
337
338
339
340
341
342
343
            'SERVER_PROTOCOL' => 'HTTP/1.1',
            ( $args{custom} ? %{ $args{custom} } : () ),
            'psgix.input.buffered' => 1,
            'psgi.input'           => $body,
            'CONTENT_LENGTH' => $args{length} // scalar( ( stat $body )[7] ),
            'CONTENT_TYPE'   => $args{type}
              || 'application/x-www-form-urlencoded',
        }
    );
}

Yadd's avatar
Yadd committed
344
1;