File Coverage

blib/lib/Apache/AppSamurai/Util.pm
Criterion Covered Total %
statement 37 80 46.2
branch 12 38 31.5
condition 1 13 7.6
subroutine 9 16 56.2
pod 10 10 100.0
total 69 157 43.9


line stmt bran cond sub pod time code
1             # Apache::AppSamurai::Util - Utility functions for AppSamurai
2              
3             # $Id: Util.pm,v 1.21 2008/04/30 21:40:06 pauldoom Exp $
4              
5             ##
6             # Copyright (c) 2008 Paul M. Hirsch (paul@voltagenoir.org).
7             # All rights reserved.
8             #
9             # This program is free software; you can redistribute it and/or modify it under
10             # the same terms as Perl itself.
11             ##
12              
13             # NOTE - This file includes content directly from CGI::Util
14              
15             # TODO - Move validation methods into this and provide methods exports
16              
17             package Apache::AppSamurai::Util;
18 1     1   27720 use strict;
  1         4  
  1         45  
19 1     1   5 use warnings;
  1         2  
  1         34  
20              
21 1     1   7 use vars qw($VERSION @EXPORT_OK @ISA $IDLEN);
  1         1  
  1         122  
22             $VERSION = substr(q$Revision: 1.21 $, 10, -1);
23              
24 1     1   1849 use Digest::SHA qw(sha256_hex hmac_sha256_hex);
  1         5285  
  1         105  
25 1     1   1721 use Time::HiRes;
  1         2654  
  1         5  
26              
27             @ISA = qw(Exporter);
28             @EXPORT_OK = qw(expires CreateSessionAuthKey CheckSidFormat
29             HashPass HashAny ComputeSessionId CheckUrlFormat CheckHostName
30             CheckHostIP XHalf);
31              
32             # $IDLEN defines the byte length for all IDs (Session IDs, Keys, etc).
33             # This should be the byte length of the main digest function used.
34             # (Provided in case something other than SHA256 is used.)
35             $IDLEN = 32;
36              
37             # -- expires() shamelessly taken from CGI::Util
38             ## -- And this expires shamelessly taken from Apache::AuthCookie::Util ;)
39             sub expires {
40 0     0 1 0 my($time,$format) = @_;
41 0   0     0 $format ||= 'http';
42              
43 0         0 my(@MON) = qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
44 0         0 my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/;
45              
46             # pass through preformatted dates for the sake of expire_calc()
47 0         0 $time = _expire_calc($time);
48 0 0       0 return $time unless $time =~ /^\d+$/;
49              
50             # make HTTP/cookie date string from GMT'ed time
51             # (cookies use '-' as date separator, HTTP uses ' ')
52 0         0 my($sc) = ' ';
53 0 0       0 $sc = '-' if $format eq "cookie";
54 0         0 my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time);
55 0         0 $year += 1900;
56 0         0 return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT",
57             $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
58             }
59              
60             # -- expire_calc() shamelessly taken from CGI::Util
61             # This internal routine creates an expires time exactly some number of
62             # hours from the current time. It incorporates modifications from
63             # Mark Fisher.
64             sub _expire_calc {
65 0     0   0 my($time) = @_;
66 0         0 my(%mult) = ('s'=>1,
67             'm'=>60,
68             'h'=>60*60,
69             'd'=>60*60*24,
70             'M'=>60*60*24*30,
71             'y'=>60*60*24*365);
72             # format for time can be in any of the forms...
73             # "now" -- expire immediately
74             # "+180s" -- in 180 seconds
75             # "+2m" -- in 2 minutes
76             # "+12h" -- in 12 hours
77             # "+1d" -- in 1 day
78             # "+3M" -- in 3 months
79             # "+2y" -- in 2 years
80             # "-3m" -- 3 minutes ago(!)
81             # If you don't supply one of these forms, we assume you are
82             # specifying the date yourself
83 0         0 my($offset);
84 0 0 0     0 if (!$time || (lc($time) eq 'now')) {
    0          
    0          
85 0         0 $offset = 0;
86             } elsif ($time=~/^\d+/) {
87 0         0 return $time;
88             } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([mhdMy]?)/) {
89 0   0     0 $offset = ($mult{$2} || 1)*$1;
90             } else {
91 0         0 return $time;
92             }
93 0         0 return (time+$offset);
94             }
95              
96              
97             # Create a session authentication key to send back to the user's browser.
98             # This is the "session key", not the local "session ID". It will be used
99             # with the server's ServerKey value to create the local session ID, and
100             # to look up a user's session going forward. This session key is also used
101             # to encrypt the user's session data. Do not log the session authentication
102             # key! All logging should reference the server side session key/ID.
103             #
104             # If no arguments are passed the key is chosen randomly, else it is a digest of
105             # the concatenated args
106             sub CreateSessionAuthKey {
107 3     3 1 1533 my $key = '';
108 3         6 my $cycles = 5;
109 3         7 my $text = '';
110              
111             # Pull in and concatenate custom key text
112 3 100       12 if (scalar @_) {
113 2         6 $text = join("", @_);
114 2 100       12 ($text =~ /^\s*$/) && ($text = '');
115             }
116              
117 3 100       10 if ($text) {
118 1         9 $key = sha256_hex($text);
119             } else {
120             # You only make a new session once in a while, so take the time to pick
121             # something hard. (Though, Bruce Schneier might very well laugh at it.)
122 2         8 for (my $i=0; $i < $cycles; $i++) {
123 10         180 $key = sha256_hex(sprintf("%0.6f", Time::HiRes::time()) . $key . $$);
124             }
125             }
126              
127             # One time I put a VERY stupid bug in this code. End result: It returned
128             # the SHA256 digest of '' for everything. Stupid. NEVER AGAIN!!!!
129             # (FYI: Yes, this method is unit tested now, too, but still...)
130 3 50       18 if ($key =~ /^e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855$/i) {
131 0         0 die "OH MY GOD!!!! That is the SHA256 of nothing, bozo!";
132             }
133              
134 3         56 return $key;
135             }
136              
137             # Hash plaintext password/passphrase
138             sub HashPass {
139 3     3 1 6 my $plain = shift;
140            
141             # Check for basic decency. (This is checked when configuring. This is just a failsafe.)
142 3 100       24 ($plain =~ /^[[:print:]]+$/s) or die "HashPass(): Invalid characters in plaintext passphrase";
143              
144 2         18 return sha256_hex($plain);
145             }
146              
147             # Just hash whatever is passed in, joining as needed
148             sub HashAny {
149 0     0 1 0 my $plain = join('', @_);
150 0         0 return sha256_hex($plain);
151             }
152            
153             # Given session authentication key from browser and ServerKey from the config.
154             # use a HMAC to compute the real session ID.
155             sub ComputeSessionId {
156 1     1 1 7 my ($authkey, $serverkey) = @_;
157              
158             # This is checked before this point. This is just a failsafe
159 1 50 33     4 (CheckSidFormat($authkey) && CheckSidFormat($serverkey)) or return undef;
160            
161 1         18 return hmac_sha256_hex($authkey, $serverkey);
162             }
163              
164             # Check the composition of the Session ID. This does not check if the ID
165             # exists and that it is well formed
166             sub CheckSidFormat {
167 2     2 1 9 my $sid = shift;
168 2 50       5 (defined($sid)) || (return undef);
169            
170 2         4 my $tlen = $IDLEN * 2;
171              
172             # Check that the ID is a hex string of length $IDLEN bytes
173 2 50       70 ($sid =~ /^([a-f0-9]{$tlen})$/i) ? (return $1) : (return undef);
174             }
175              
176             # Check full URL (host + args). Untaints as it cleans. Returns undef if it
177             # ain't clean.
178             sub CheckUrlFormat {
179 0     0 1   my $url = shift;
180             # Following check pulled out of OWASP FAQ, and converted for Perl
181 0 0         ($url =~ /((((https?|ftps?|gopher|telnet|nntp):\/\/)|(mailto:|news:))(%[0-9A-Fa-f]{2}|[\-\(\)_\.!\~\*\';\/\?:\@\&=\+\$,A-Za-z0-9])+)([\)\.!\';\/\?:,][[:blank:]])?$/) ? (return $1) : (return undef);
182             }
183              
184             # Check host address or DNS name. NOT A STRICT TEST! This will allow in
185             # IPv4 and v6 and most DNS names. Use CheckHostIP for a strict IPv4 check.
186             sub CheckHostName {
187 0     0 1   my $hostname = shift;
188 0 0         ($hostname =~ /^\s*([\w\d\-\_\.\:]+)\s*$/) ? (return $1) : (return undef);
189             }
190              
191             # Check IPv4 or IPv6 IP for valid format, using a nice little regex
192             # for the IPv4 check, and a hellaciously long but (as far as I can tell,
193             # good) regex from http://www.regexlib.com/REDetails.aspx?regexp_id=1000 by
194             # Jeff Johnston for IPv6 checks.
195             sub CheckHostIP {
196 0     0 1   my $ip = shift;
197 0           my @t;
198              
199 0 0         if ($ip =~ /^\s*(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})\s*$/) {
200             # It is IPv4
201 0           @t = ($1, $2, $3, $4);
202 0           foreach (@t) {
203             # Strip leading 0s
204 0           s/^0{1,2}(\d)/$1/;
205 0 0         ($1 < 256) || (return undef); # One of the octets is too big
206             }
207 0           return join('.', @t);
208             } #elsif ($ip =~ /^\s*((([0-9A-F]{1,4}:){7}[0-9A-F]{1,4})|(((0-9A-F]{1,4}:){6}:[0-9A-F]{1,4})|(([0-9A-F]{1,4}:){5}:([0-9A-F]{1,4}:)?[0-9A-F]{1,4})|(([0-9A-F]{1,4}:){4}:([0-9A-F]{1,4}:){0,2}[0-9A-F]{1,4})|(([0-9A-F]{1,4}:){3}:([0-9A-F]{1,4}:){0,3}[0-9A-F]{1,4})|(([0-9A-F]{1,4}:){2}:([0-9A-F]{1,4}:){0,4}[0-9A-F]{1,4})|(([0-9A-F]{1,4}:){6}((\b((25[0-5])|(1\d{2})|(2[0-4]\d)|(\d{1,2}))\b)\.){3}(\b((25[0-5])|(1\d{2})|(2[0-4]\d)|(\d{1,2}))\b))|(([0-9A-F]{1,4}:){0,5}:((\b((25[0-5])|(1\d{2})|(2[0-4]\d)|(\d{1,2}))\b)\.){3}(\b((25[0-5])|(1\d{2})|(2[0-4]\d)|(\d{1,2}))\b))|(::([0-9A-F]{1,4}:){0,5}((\b((25[0-5])|(1\d{2})|(2[0-4]\d)|(\d{1,2}))\b)\.){3}(\b((25[0-5])|(1\d{2})|(2[0-4]\d)|(\d{1,2}))\b))|([0-9A-F]{1,4}::([0-9A-F]{1,4}:){0,5}[0-9A-F]{1,4})|(::([0-9A-F]{1,4}:){0,6}[0-9A-F]{1,4})|(([0-9A-F]{1,4}:){1,7}:))\s*$/i) {
209             # Thanks to Jeff Johnston for the above. Slightly shortened by
210             # removing a-f set and adding /i to the end. So, a programmatic
211             # check may have been easier. I'll stick with the regex-matic check.
212             #return $ip;
213             #}
214              
215             # Doesn't look IP-ish
216 0           return undef;
217             }
218              
219             # X out the second half of the string. Used for debugging to reduce (BUT
220             # NOT ELIMINATE) the risk of sensitive information ending up in log files.
221             sub XHalf {
222 0     0 1   my $text = shift;
223              
224 0 0         if ($text) {
225 0           my $lb = int(length($text) / 2);
226 0 0 0       if (($lb) && ($text =~ s/.{$lb}$/"X" x $lb/e)) {
  0            
227 0           return $text;
228             }
229             }
230              
231             # Better empty than sorry
232 0           return "";
233             }
234              
235             1; # End of Apache::AppSamurai::Tracker
236              
237             __END__