2020-07-16 20:48:53 -05:00
#!/usr/bin/env perl
use utf8 ;
use strict ;
use warnings ;
use open qw( :std :utf8 ) ;
######################
# Server Configuration
######################
2020-07-17 21:36:12 -05:00
my $ server_port = $ ENV { 'PORT' } || 4227 ;
2020-07-18 15:23:29 -05:00
my $ pid_file = $ ENV { 'PID_FILE' } || './data/dotplan.pid' ;
my $ log_file = $ ENV { 'LOG_FILE' } || './data/dotplan.log' ;
my $ database = $ ENV { 'DATABASE' } || './data/users.db' ;
my $ plan_dir = $ ENV { 'PLAN_DIR' } || './data/plans' ;
2020-07-24 00:26:43 -05:00
my $ cache_dir = $ ENV { 'CACHE_DIR' } || './data/cache' ;
2020-07-23 18:39:34 -05:00
my $ sendmail = $ ENV { 'SENDMAIL' } ;
2020-07-20 22:13:03 -05:00
my @ sendmail_args = defined $ ENV { 'SENDMAIL_ARGS' } ? split ( /,/ , $ ENV { 'SENDMAIL_ARGS' } ) : ( ) ;
2020-07-17 21:36:12 -05:00
my $ pw_token_expiration_minutes = $ ENV { 'PW_TOKEN_EXPIRATION_MINUTES' } || 10 ;
my $ auth_token_default_expiration_minutes = $ ENV { 'AUTH_TOKEN_DEFAULT_EXPIRATION_MINUTES' } || 5 ;
my $ minimum_password_length = $ ENV { 'MINIMUM_PASSWORD_LENGTH' } || 8 ;
my $ minimum_email_length = $ ENV { 'MINIMUM_EMAIL_LENGTH' } || 6 ;
my $ maximum_email_length = $ ENV { 'MAXIMUM_EMAIL_LENGTH' } || 120 ;
my $ maximum_plan_length = $ ENV { 'MAXIMUM_PLAN_LENGTH' } || 4096 ;
my $ maximum_signature_length = $ ENV { 'MAXIMUM_SIGNATURE_LENGTH' } || 1024 ;
2020-07-17 23:57:40 -05:00
my $ maximum_pubkey_length = $ ENV { 'MAXIMUM_PUBKEY_LENGTH' } || 5125 ;
2020-07-17 21:36:12 -05:00
2020-07-19 19:35:47 -05:00
my $ hostname = $ ENV { 'HOSTNAME' } || '' ;
2020-07-19 15:47:30 -05:00
my $ from_address = $ ENV { 'MAIL_FROM' } || "do-not-reply\@$hostname" ;
2020-07-17 21:36:12 -05:00
my $ localdomains = { } ;
if ( defined $ ENV { 'LOCAL_DOMAINS' } ) {
$ localdomains - > { $ _ } + + for ( split ( /,/ , $ ENV { 'LOCAL_DOMAINS' } ) ) ;
}
2020-07-16 20:48:53 -05:00
2021-06-23 09:08:32 -05:00
my $ enable_experimental_features = $ ENV { 'ENABLE_EXPERIMENTAL_FEATURES' } || 0 ;
2020-07-16 20:48:53 -05:00
#########################################
# dotplan.online Reference Implementation
#########################################
{
package DotplanApi ;
use base qw( HTTP::Server::Simple::CGI ) ;
2020-07-18 15:23:29 -05:00
sub net_server { 'Net::Server::Fork' }
2020-07-21 00:14:50 -05:00
my $ webroot = './static' ;
2020-07-16 23:55:59 -05:00
2020-07-24 00:26:43 -05:00
use Cache::FileCache ;
2020-07-23 21:27:32 -05:00
use HTTP::Server::Simple::Static ;
2020-07-18 15:23:29 -05:00
use IPC::Run ;
2020-07-17 21:36:12 -05:00
use DBI ;
2020-07-17 23:57:40 -05:00
use File::Temp qw( tempfile ) ;
2020-07-17 21:36:12 -05:00
use Fcntl qw( :flock ) ;
use Net::DNS::Resolver ;
2020-07-19 10:04:08 -05:00
use Crypt::Random qw( makerandom_itv ) ;
2020-07-17 21:36:12 -05:00
use Crypt::Eksblowfish::Bcrypt qw( bcrypt_hash en_base64 ) ;
use MIME::Base64 qw( decode_base64 ) ;
2020-07-16 20:48:53 -05:00
use POSIX qw( strftime ) ;
use JSON qw( encode_json decode_json ) ;
2020-07-23 18:29:56 -05:00
use HTTP::Accept ;
2020-07-21 00:14:50 -05:00
use URI::Escape qw( uri_escape uri_unescape ) ;
2020-07-20 22:13:03 -05:00
use File::Spec::Functions qw( catfile ) ;
2021-06-22 10:29:21 -05:00
use HTML::Entities qw( encode_entities ) ;
2020-07-16 20:48:53 -05:00
2020-07-24 00:26:43 -05:00
########
# Caches
########
# cache plans by email
my $ _plancache = Cache::FileCache - > new ( { cache_root = > $ cache_dir , namespace = > 'plan' , default_expires_in = > 3600 } ) ;
# cache SRV records by domain
my $ _srvcache = Cache::FileCache - > new ( { cache_root = > $ cache_dir , namespace = > 'srv' , default_expires_in = > 3600 } ) ;
# cache static responses
my $ _staticcache = Cache::FileCache - > new ( { cache_root = > $ cache_dir , namespace = > 'static' , default_expires_in = > 3600 } ) ;
2020-07-16 20:48:53 -05:00
###############
# Common Errors
###############
2020-07-16 23:55:59 -05:00
my $ resp_header = {
200 = > 'OK' ,
2020-07-17 21:36:12 -05:00
301 = > 'Moved Permanently' ,
2020-07-21 00:14:50 -05:00
304 = > 'Not Modified' ,
2020-07-17 21:36:12 -05:00
400 = > 'Bad Request' ,
401 = > 'Unauthorized' ,
2020-07-23 18:29:56 -05:00
403 = > 'Forbidden' ,
2020-07-16 23:55:59 -05:00
404 = > 'Not Found' ,
2020-07-17 21:36:12 -05:00
405 = > 'Method Not Allowed' ,
2020-07-23 18:29:56 -05:00
406 = > 'Not Acceptable' ,
2020-07-17 21:36:12 -05:00
429 = > 'Too Many Requests' ,
500 = > 'Internal Server Error'
2020-07-16 23:55:59 -05:00
} ;
2020-07-16 20:48:53 -05:00
2020-07-23 18:29:56 -05:00
my $ resp_body = {
301 = > 'Redirecting to the appropriate server for that plan.' ,
401 = > 'The authorization details provided did not match our records.' ,
403 = > 'The requested plan signature could not be verified with the specified public key.' ,
404 = > 'The requested resource was not found.' ,
405 = > 'The server does not support the specified request method.' ,
406 = > 'The server does not support any of the requested Content-Types.' ,
500 = > 'An unexpected error occurred.'
} ;
2020-07-16 20:48:53 -05:00
#################
# Request Routing
#################
2020-07-23 18:45:16 -05:00
#
my $ routes = [
{
path = > qr/^\/ plan \ /([^\/]{$minimum_email_length,$maximum_email_length})$/ ,
methods = > {
GET = > { handler = > \ & get_plan , valid_types = > [ 'application/json' , 'text/plain' ] } ,
HEAD = > { handler = > \ & get_plan , valid_types = > [ 'application/json' , 'text/plain' ] } ,
PUT = > { handler = > \ & update_plan , valid_types = > [ 'application/json' ] }
}
} ,
{
path = > qr/^\/ token $/ ,
methods = > {
GET = > { handler = > \ & get_token , valid_types = > [ 'application/json' ] } ,
DELETE = > { handler = > \ & delete_token , valid_types = > [ 'application/json' ] }
}
} ,
{
path = > qr/^\/ users \ /([^\/]{$minimum_email_length,$maximum_email_length})\/pwchange$/ ,
methods = > {
GET = > { handler = > \ & get_pwtoken , valid_types = > [ 'application/json' ] } ,
PUT = > { handler = > \ & update_password , valid_types = > [ 'application/json' ] }
}
} ,
{
path = > qr/^\/ users \ /([^\/]{$minimum_email_length,$maximum_email_length})$/ ,
methods = > {
POST = > { handler = > \ & create_user , valid_types = > [ 'application/json' ] } ,
PUT = > { handler = > \ & validate_email , valid_types = > [ 'application/json' ] }
}
} ,
2021-06-23 09:08:32 -05:00
# experimental features:
2021-06-22 10:29:21 -05:00
{
path = > qr/^\/ js \ /([^\/]{$minimum_email_length,$maximum_email_length})$/ ,
methods = > {
GET = > { handler = > \ & get_plan_js , valid_types = > [ 'application/javascript' ] }
}
}
2020-07-23 18:45:16 -05:00
] ;
2020-07-16 20:48:53 -05:00
sub handle_request {
my ( $ self , $ cgi ) = @ _ ;
2020-07-17 21:36:12 -05:00
# assign a random request id for anonymous logging
2020-07-19 10:04:08 -05:00
my $ req_id = util_token ( 12 ) ;
2020-07-17 21:36:12 -05:00
$ cgi - > param ( 'request_id' , $ req_id ) ;
2020-07-16 20:48:53 -05:00
my $ path = $ cgi - > path_info ( ) ;
2020-07-21 00:14:50 -05:00
$ path =~ s{^https?://([^/:]+)(:\d+)?/} {/} ;
$ cgi - > { '.path_info' } = '/index.html' if $ path eq '/' ;
2020-07-16 20:48:53 -05:00
my $ method = $ cgi - > request_method ( ) ;
2020-07-23 18:29:56 -05:00
my $ accept = HTTP::Accept - > new ( $ cgi - > http ( 'Accept' ) ) ;
$ cgi - > param ( 'accept' , $ accept ) ;
my $ body = $ cgi - > param ( 'POSTDATA' ) || $ cgi - > param ( 'PUTDATA' ) ;
if ( defined $ body ) {
eval {
$ cgi - > param ( 'json-body' , decode_json ( $ body ) ) ;
} ;
if ( $@ ) {
print_json_response ( $ cgi , 400 , { error = > 'Unable to parse json payload.' } ) ;
return ;
}
} else {
$ cgi - > param ( 'json-body' , { } ) ;
}
2020-07-17 21:36:12 -05:00
2020-07-23 18:29:56 -05:00
eval {
util_log ( "REQ $req_id $method $path" ) ;
# check for matching handler
foreach my $ route ( @$ routes ) {
if ( $ path =~ $ route - > { 'path' } ) {
my $ param = $ 1 ;
if ( defined $ route - > { 'methods' } - > { $ method } ) {
if ( $ accept - > match ( @ { $ route - > { 'methods' } - > { $ method } - > { 'valid_types' } } ) ) {
$ route - > { 'methods' } - > { $ method } - > { 'handler' } - > ( $ cgi , $ param ) ;
return ;
} else {
print_response ( $ cgi , 406 ) ;
return ;
}
} else {
print_response ( $ cgi , 405 ) ;
return ;
}
2020-07-17 21:36:12 -05:00
}
2020-07-23 18:29:56 -05:00
}
# if no handler, check for static file
2020-07-24 00:26:43 -05:00
if ( ! cached_static_file ( $ self , $ cgi , $ path ) ) {
2020-07-23 18:29:56 -05:00
print_response ( $ cgi , 404 ) ;
2020-07-16 20:48:53 -05:00
}
2020-07-17 21:36:12 -05:00
} ;
if ( $@ ) {
util_log ( "ERR $req_id $@" ) ;
2020-07-23 18:29:56 -05:00
print_response ( $ cgi , 500 ) ;
2020-07-16 20:48:53 -05:00
}
}
2020-07-24 00:26:43 -05:00
sub cached_static_file {
my ( $ server , $ cgi , $ path ) = @ _ ;
my $ cached = $ _staticcache - > get ( $ path ) ;
if ( ! defined $ cached ) {
open local ( * STDOUT ) , '>' , \ $ cached ;
if ( ! serve_static ( $ server , $ cgi , $ webroot ) ) {
$ cached = 0 ;
}
$ _staticcache - > set ( $ path , $ cached ) ;
}
print $ cached if $ cached ;
return $ cached ;
}
###################
# Response Handlers
###################
2020-07-16 20:48:53 -05:00
sub print_response {
2020-07-23 18:29:56 -05:00
my ( $ cgi , $ code , $ headers , $ body ) = @ _ ;
2020-07-17 21:36:12 -05:00
my $ req_id = $ cgi - > param ( 'request_id' ) ;
my $ path = $ cgi - > path_info ( ) ;
my $ method = $ cgi - > request_method ( ) ;
util_log ( "RES($code) $req_id $method $path" ) ;
2020-07-23 18:29:56 -05:00
$ headers = { } if ! defined $ headers ;
$ headers - > { 'Content-Type' } = $ cgi - > param ( 'accept' ) - > match ( qw( application/json text/plain ) ) || 'application/json' if ! defined $ headers - > { 'Content-Type' } ;
my $ code_description = $ resp_header - > { $ code } ;
if ( ! defined $ body && defined $ resp_body - > { $ code } ) {
$ body = $ headers - > { 'Content-Type' } eq 'application/json'
? encode_json ( { error = > $ resp_body - > { $ code } } )
: $ resp_body - > { $ code } ;
2020-07-16 20:48:53 -05:00
}
2022-05-08 15:12:59 -05:00
my $ length ;
{
use bytes ;
$ length = defined $ body ? length ( $ body ) : 0 ;
} ;
2020-07-23 18:29:56 -05:00
$ body = '' if ! defined $ body || $ cgi - > request_method ( ) eq 'HEAD' ;
my $ length_header = '' ;
2020-07-21 00:38:39 -05:00
if ( $ length > 0 ) {
2020-07-23 18:29:56 -05:00
$ length_header = "\nContent-Length: $length" ;
2020-07-21 00:38:39 -05:00
}
2020-07-21 00:14:50 -05:00
my $ now = time ;
my $ date = HTTP::Date:: time2str ( $ now ) ;
2020-07-23 18:29:56 -05:00
my $ extra_headers = '' ;
foreach my $ header ( keys %$ headers ) {
my $ val = $ headers - > { $ header } ;
$ extra_headers . = "\n$header: $val" ;
2020-07-21 00:14:50 -05:00
}
2022-05-08 15:12:59 -05:00
binmode STDOUT , ':utf8' ;
2020-07-16 20:48:53 -05:00
print << EOF ;
2020-07-23 18:29:56 -05:00
HTTP / 1.1 $ code $ code_description
2020-07-16 20:48:53 -05:00
Server: DotplanApi
2020-07-23 18:29:56 -05:00
Date: $ date $ extra_headers $ length_header
2020-07-16 20:48:53 -05:00
EOF
print "\n$body" ;
}
2020-07-17 21:36:12 -05:00
sub print_json_response {
2020-07-23 18:29:56 -05:00
my ( $ cgi , $ code , $ data , $ headers ) = @ _ ;
if ( ! defined $ headers ) {
$ headers = { } ;
} ;
$ headers - > { 'Content-Type' } = 'application/json' ;
print_response ( $ cgi , $ code , $ headers , encode_json ( $ data ) ) ;
2020-07-17 21:36:12 -05:00
}
2020-07-16 20:48:53 -05:00
####################
# API Implementation
####################
2020-07-16 23:55:59 -05:00
##### POST /users/{email}
2020-07-17 21:36:12 -05:00
sub create_user {
2020-07-23 18:29:56 -05:00
my ( $ cgi , $ email ) = @ _ ;
2020-07-17 21:36:12 -05:00
if ( $ email !~ /^[^\@]+\@[^\@\.]+\.[^\@]+$/ ) {
2020-07-23 18:29:56 -05:00
print_json_response ( $ cgi , 400 , { error = > 'Only email addresses of the form {local}@{domain.tld} are supported by this server.' } ) ;
return ;
}
my $ user = util_get_user ( $ email ) ;
if ( defined $ user && $ user - > { 'verified' } ) {
print_json_response ( $ cgi , 400 , { error = > 'User already exists.' } ) ;
return ;
}
if ( defined $ user && defined $ user - > { 'pw_token_expires' } && $ user - > { 'pw_token_expires' } >= time ) {
print_json_response ( $ cgi , 429 , { error = > "Wait $pw_token_expiration_minutes minutes between this type of request." } ) ;
return ;
}
my $ password = $ cgi - > param ( 'json-body' ) - > { 'password' } ;
if ( ! defined $ password || length ( $ password ) < $ minimum_password_length ) {
print_json_response ( $ cgi , 400 , { error = > "Password must be at least $minimum_password_length characters long." } ) ;
return ;
2020-07-17 21:36:12 -05:00
}
2020-07-23 18:29:56 -05:00
my $ query = ( defined $ user )
? "UPDATE users SET password=?, pw_token=?, pw_token_expires=datetime('now', '+$pw_token_expiration_minutes minutes') WHERE email=?"
: "INSERT INTO users (password, pw_token, pw_token_expires, email) values (?, ?, datetime('now', '+$pw_token_expiration_minutes minutes'), ?)" ;
my $ crypted = util_bcrypt ( $ password ) ;
my $ sth = util_get_dbh ( ) - > prepare ( $ query ) ;
my $ token = util_token ( 24 ) ;
$ sth - > execute ( $ crypted , $ token , $ email ) ;
die $ sth - > errstr if $ sth - > err ;
2020-07-23 18:39:34 -05:00
util_sendmail ( $ cgi , $ email , '[DOTPLAN] Verify your email' ,
2020-07-23 18:29:56 -05:00
"Please verify your email address.\n" .
2021-06-20 18:20:35 -05:00
"Your verification token is: $token\n" .
"Run this (or equivalent) in a terminal:\n\n" .
" curl -H 'Content-Type: application/json' \\\n" .
2021-06-21 19:37:35 -05:00
" -XPUT -d '{\"token\":\"$token\"}' \\\n" .
2021-06-20 18:20:35 -05:00
" https://$hostname/users/$email" ) ;
2020-07-23 18:29:56 -05:00
print_json_response ( $ cgi , 200 , { email = > $ email } ) ;
2020-07-17 21:36:12 -05:00
}
2020-07-16 23:55:59 -05:00
2020-07-23 18:29:56 -05:00
##### PUT /users/{email}
2020-07-17 21:36:12 -05:00
sub validate_email {
2020-07-23 18:29:56 -05:00
my ( $ cgi , $ email ) = @ _ ;
my $ token = $ cgi - > param ( 'json-body' ) - > { 'token' } ;
2020-07-17 21:36:12 -05:00
if ( ! defined $ token ) {
2020-07-19 09:28:37 -05:00
print_json_response ( $ cgi , 400 , { error = > 'Missing token.' } ) ;
2020-07-23 18:29:56 -05:00
return ;
2020-07-17 21:36:12 -05:00
}
2020-07-23 18:29:56 -05:00
my $ user = util_get_user ( $ email ) ;
if ( ! defined $ user || $ user - > { 'verified' } ) {
print_response ( $ cgi , 404 ) ;
return ;
}
if ( $ user - > { 'pw_token' } ne $ token ) {
print_response ( $ cgi , 401 ) ;
return ;
}
my $ sth = util_get_dbh ( ) - > prepare ( 'UPDATE users SET verified=1, pw_token=null, pw_token_expires=null WHERE email=?' ) ;
$ sth - > execute ( $ email ) ;
die $ sth - > errstr if $ sth - > err ;
print_json_response ( $ cgi , 200 , { success = > 1 } ) ;
2020-07-17 21:36:12 -05:00
}
2020-07-16 23:55:59 -05:00
2020-07-17 21:36:12 -05:00
##### GET /token
sub get_token {
my $ cgi = shift ;
my $ user = util_get_authenticated ( $ cgi ) ;
if ( ! defined $ user ) {
2020-07-23 18:29:56 -05:00
print_response ( $ cgi , 401 ) ;
return ;
}
my $ sth = util_get_dbh ( ) - > prepare ( "UPDATE users SET token=?, token_expires=datetime('now', ?) WHERE email=?" ) ;
my $ token = util_token ( 24 ) ;
my $ expires = $ cgi - > param ( 'expires' ) ;
my $ minutes = $ auth_token_default_expiration_minutes ;
if ( defined $ expires && $ expires =~ /^\d+$/ ) {
$ minutes = int ( $ expires ) ;
if ( $ minutes <= 0 ) {
$ minutes = $ auth_token_default_expiration_minutes ;
2020-07-17 21:36:12 -05:00
}
}
2020-07-23 18:29:56 -05:00
$ sth - > execute ( $ token , "+$minutes minutes" , $ user - > { 'email' } ) ;
die $ sth - > errstr if $ sth - > err ;
print_json_response ( $ cgi , 200 , { token = > $ token } ) ;
2020-07-17 21:36:12 -05:00
}
2020-07-16 23:55:59 -05:00
2020-07-17 21:36:12 -05:00
##### DELETE /token
sub delete_token {
my $ cgi = shift ;
my $ user = util_get_authenticated ( $ cgi ) ;
if ( ! defined $ user ) {
2020-07-23 18:29:56 -05:00
print_response ( $ cgi , 401 ) ;
return ;
2020-07-17 21:36:12 -05:00
}
2020-07-23 18:29:56 -05:00
my $ sth = util_get_dbh ( ) - > prepare ( 'UPDATE users SET token=null, token_expires=null WHERE email=?' ) ;
$ sth - > execute ( $ user - > { 'email' } ) ;
die $ sth - > errstr if $ sth - > err ;
print_json_response ( $ cgi , 200 , { success = > 1 } ) ;
2020-07-17 21:36:12 -05:00
}
2020-07-16 23:55:59 -05:00
2020-07-23 18:29:56 -05:00
##### GET /users/{email}/pwchange
2020-07-17 21:36:12 -05:00
sub get_pwtoken {
2020-07-23 18:29:56 -05:00
my ( $ cgi , $ email ) = @ _ ;
2020-07-17 21:36:12 -05:00
my $ user = util_get_user ( $ email ) ;
if ( ! defined $ user || ! $ user - > { 'verified' } ) {
2020-07-23 18:29:56 -05:00
print_response ( $ cgi , 404 ) ;
return ;
}
if ( defined $ user - > { 'pw_token_expires' } && $ user - > { 'pw_token_expires' } >= time ) {
2020-07-19 09:28:37 -05:00
print_json_response ( $ cgi , 429 , { error = > "Wait $pw_token_expiration_minutes between this type of request." } ) ;
2020-07-23 18:29:56 -05:00
return ;
2020-07-17 21:36:12 -05:00
}
2020-07-23 18:29:56 -05:00
my $ token = util_token ( 24 ) ;
my $ sth = util_get_dbh ( ) - > prepare ( "UPDATE users SET pw_token=?, pw_token_expires=datetime('now', '+10 minutes') WHERE email=?" ) ;
$ sth - > execute ( $ token , $ email ) ;
die $ sth - > errstr if $ sth - > err ;
2020-07-23 18:39:34 -05:00
util_sendmail ( $ cgi , $ email , '[DOTPLAN] Password reset request' ,
2020-07-23 18:29:56 -05:00
"Someone (hopefully you) has requested to change your password.\n" .
"If it wasn't you, you can ignore and delete this email.\n\n" .
2021-06-20 18:20:35 -05:00
"Your password change token is: $token\n\n" .
"Run this (or equivalent) in a terminal after adding your desired\n" .
"password to the appropriate field in the JSON payload:\n\n" .
" curl -H 'Content-Type: application/json' \\\n" .
2021-06-21 19:37:35 -05:00
" -XPUT -d '{\"password\":\"\",\"token\":\"$token\"}' \\\n" .
2021-06-20 18:20:35 -05:00
" https://$hostname/users/$email/pwchange" ) ;
2020-07-23 18:29:56 -05:00
print_json_response ( $ cgi , 200 , { success = > 1 } ) ;
2020-07-17 21:36:12 -05:00
}
2020-07-16 23:55:59 -05:00
2020-07-23 18:29:56 -05:00
##### PUT /users/{email}/pwchange
2020-07-17 21:36:12 -05:00
sub update_password {
2020-07-23 18:29:56 -05:00
my ( $ cgi , $ email ) = @ _ ;
2020-07-17 21:36:12 -05:00
my $ user = util_get_user ( $ email ) ;
if ( ! defined $ user || ! $ user - > { 'verified' } ) {
2020-07-23 18:29:56 -05:00
print_response ( $ cgi , 404 ) ;
return ;
2020-07-17 21:36:12 -05:00
}
2020-07-23 18:29:56 -05:00
my $ body = $ cgi - > param ( 'json-body' ) ;
my $ password = $ body - > { 'password' } ;
my $ pwtoken = $ body - > { 'token' } ;
if ( ! defined $ pwtoken || ! defined $ user - > { 'pw_token' } || ! defined $ user - > { 'pw_token_expires' } || $ pwtoken ne $ user - > { 'pw_token' } || $ user - > { 'pw_token_expires' } < time ) {
print_json_response ( $ cgi , 400 , { error = > 'Bad or expired token.' } ) ;
return ;
}
if ( ! defined $ password || length ( $ password ) < $ minimum_password_length ) {
print_json_response ( $ cgi , 400 , { error = > "Password must be at least $minimum_password_length characters long." } ) ;
return ;
}
my $ crypted = util_bcrypt ( $ password ) ;
my $ sth = util_get_dbh ( ) - > prepare ( 'UPDATE users SET password=?, pw_token=null, pw_token_expires=null, token=null, token_expires=null WHERE email=?' ) ;
$ sth - > execute ( $ crypted , $ email ) ;
die $ sth - > errstr if $ sth - > err ;
print_json_response ( $ cgi , 200 , { success = > 1 } ) ;
2020-07-17 21:36:12 -05:00
}
2020-07-16 23:55:59 -05:00
##### PUT /plan/{email}
2020-07-17 21:36:12 -05:00
sub update_plan {
2020-07-23 18:29:56 -05:00
my ( $ cgi , $ email ) = @ _ ;
2020-07-17 21:36:12 -05:00
my $ user = util_get_user ( $ email ) ;
if ( ! defined $ user || ! $ user - > { 'verified' } ) {
2020-07-23 18:29:56 -05:00
print_response ( $ cgi , 404 ) ;
return ;
2020-07-17 21:36:12 -05:00
}
2020-07-23 18:29:56 -05:00
my $ body = $ cgi - > param ( 'json-body' ) ;
my $ plan = $ body - > { 'plan' } ;
my $ signature = $ body - > { 'signature' } ;
my $ token = $ body - > { 'auth' } ;
if ( ! defined $ user - > { 'token' } || ! defined $ user - > { 'token_expires' } || ! defined $ token || $ token ne $ user - > { 'token' } || $ user - > { 'token_expires' } < time ) {
print_response ( $ cgi , 401 ) ;
return ;
}
if ( defined $ plan && length ( $ plan ) > $ maximum_plan_length ) {
print_json_response ( $ cgi , 400 , { error = > "Plan exceeds maximum length of $maximum_plan_length." } ) ;
return ;
}
if ( defined $ signature && length ( $ signature ) > $ maximum_signature_length ) {
print_json_response ( $ cgi , 400 , { error = > "Signature exceeds maximum length of $maximum_signature_length." } ) ;
return ;
}
util_save_plan ( $ email , $ plan , $ signature ) ;
print_json_response ( $ cgi , 200 , { success = > 1 } ) ;
2020-07-17 21:36:12 -05:00
}
2020-07-16 23:55:59 -05:00
2020-07-16 20:48:53 -05:00
##### GET /plan/{email}
sub get_plan {
2020-07-23 18:29:56 -05:00
my ( $ cgi , $ email ) = @ _ ;
2020-07-16 20:48:53 -05:00
2020-07-16 23:55:59 -05:00
my $ plan = util_get_plan ( $ email ) ;
2021-06-19 12:27:58 -05:00
my $ format = $ cgi - > param ( 'accept' ) - > match ( qw( text/plain application/json ) ) ;
2020-07-16 20:48:53 -05:00
2020-07-17 21:36:12 -05:00
if ( defined $ plan && defined $ plan - > { 'redirect' } ) {
# found external plan service, redirect request
2020-07-23 18:29:56 -05:00
print_response ( $ cgi , 301 , { Location = > $ plan - > { 'redirect' } } ) ;
return ;
2020-07-16 20:48:53 -05:00
}
2020-07-23 18:29:56 -05:00
if ( ! defined $ plan ) {
2021-06-19 12:27:58 -05:00
my $ body = $ format eq 'text/plain' ? 'No Plan.' : encode_json ( { error = > 'No Plan.' } ) ;
print_response ( $ cgi , 404 , { 'Content-Type' = > $ format } , $ body ) ;
2020-07-23 18:29:56 -05:00
return ;
}
my $ pubkey = $ cgi - > http ( 'X-Dotplan-Pubkey' ) ;
if ( ( defined $ pubkey && ! defined $ plan - > { 'signature' } ) ||
( defined $ pubkey && ! util_verify_plan ( $ email , $ pubkey ) ) ) {
print_response ( $ cgi , 403 ) ;
return ;
}
# check modified time
my $ now = time ;
my $ mtime = $ plan - > { 'mtime' } ;
my $ ifmod = $ cgi - > http ( 'If-Modified-Since' ) ;
my $ ifmtime = HTTP::Date:: str2time ( $ ifmod ) if defined $ ifmod ;
if ( defined $ mtime && defined $ ifmtime && $ ifmtime <= $ now && $ mtime <= $ ifmtime ) {
print_response ( $ cgi , 304 ) ;
return ;
}
# render response
my $ body ;
delete $ plan - > { 'mtime' } ;
if ( $ format eq 'application/json' ) {
$ body = encode_json ( $ plan ) ;
2020-07-17 23:57:40 -05:00
} else {
2020-07-23 18:29:56 -05:00
$ body = $ plan - > { 'plan' } ;
}
my $ headers = {
'Content-Type' = > $ format ,
'Last-Modified' = > HTTP::Date:: time2str ( $ mtime )
} ;
if ( defined $ pubkey ) {
$ headers - > { 'X-Dotplan-Verified' } = 'true' ;
2020-07-17 23:57:40 -05:00
}
2020-07-23 18:29:56 -05:00
print_response ( $ cgi , 200 , $ headers , $ body ) ;
2020-07-17 23:57:40 -05:00
}
2020-07-16 20:48:53 -05:00
2021-06-22 10:29:21 -05:00
##### GET /js/{email}
sub get_plan_js {
my ( $ cgi , $ email ) = @ _ ;
2021-06-23 09:08:32 -05:00
if ( ! $ enable_experimental_features ) {
print_response ( $ cgi , 404 ) ;
return ;
}
2021-06-22 10:29:21 -05:00
my $ plan = util_get_plan ( $ email ) ;
if ( ! defined $ plan || defined $ plan - > { 'redirect' } ) {
# js can only be requested for locally served plans
print_response ( $ cgi , 404 ) ;
return ;
}
2021-08-29 18:08:54 -05:00
my $ callback = $ cgi - > param ( 'callback' ) || 'handle_dotplan' ;
my $ pubkey = $ cgi - > param ( 'pubkey' ) ;
my $ planJson = encode_json ( $ plan ) ;
2021-06-22 10:29:21 -05:00
if ( ( defined $ pubkey && ! defined $ plan - > { 'signature' } ) ||
( defined $ pubkey && ! util_verify_plan ( $ email , $ pubkey ) ) ) {
2021-08-29 18:08:54 -05:00
$ planJson = '{"error":"The requested plan signature could not be verified with the specified public key."}' ;
2021-06-22 10:29:21 -05:00
}
# check modified time
my $ now = time ;
my $ mtime = $ plan - > { 'mtime' } ;
my $ ifmod = $ cgi - > http ( 'If-Modified-Since' ) ;
my $ ifmtime = HTTP::Date:: str2time ( $ ifmod ) if defined $ ifmod ;
if ( defined $ mtime && defined $ ifmtime && $ ifmtime <= $ now && $ mtime <= $ ifmtime ) {
print_response ( $ cgi , 304 ) ;
return ;
}
# render response
2021-08-29 18:08:54 -05:00
my $ body = "(function() { $callback($planJson); })();" ;
2021-06-22 10:29:21 -05:00
my $ headers = {
'Content-Type' = > 'application/javascript' ,
'Last-Modified' = > HTTP::Date:: time2str ( $ mtime )
} ;
print_response ( $ cgi , 200 , $ headers , $ body ) ;
}
2020-07-16 23:55:59 -05:00
###################
# Utility Functions
###################
2020-07-16 20:48:53 -05:00
2020-07-17 21:36:12 -05:00
# get a database connection
my $ _dbh = undef ;
sub util_get_dbh {
if ( ! defined $ _dbh ) {
$ _dbh = DBI - > connect ( "DBI:SQLite:dbname=$database" , '' , '' , { RaiseError = > 1 } ) or die $ DBI:: errstr ;
}
return $ _dbh ;
}
# print a line to the log
my $ _log = undef ;
sub util_log {
my $ msg = shift ;
my $ timestamp = strftime ( "%Y-%m-%d %H:%M:%S" , localtime ( time ( ) ) ) ;
if ( ! defined $ _log ) {
2020-07-19 10:04:08 -05:00
open ( $ _log , '>>' , $ log_file ) or die $! ;
2020-07-17 21:36:12 -05:00
binmode ( $ _log , ':unix' ) ;
}
print $ _log "$timestamp $msg\n" ;
}
2020-07-19 15:47:30 -05:00
# send an email
sub util_sendmail {
2020-07-23 18:39:34 -05:00
my ( $ cgi , $ recipient , $ subject , $ body ) = @ _ ;
2020-07-19 15:47:30 -05:00
my $ email = << EOF ;
To: $ recipient
From: $ from_address
Subject: $ subject
$ body
EOF
2020-07-23 18:39:34 -05:00
if ( defined $ sendmail ) {
eval {
my @ arg = ( $ sendmail ) ;
push @ arg , @ sendmail_args ;
push @ arg , $ recipient ;
IPC::Run:: run \ @ arg , \ $ email or die "sendmail exited with $?" ;
} ;
if ( $@ ) {
my $ req_id = $ cgi - > param ( 'request_id' ) ;
util_log ( "ERR(sendmail) $req_id $@" ) ;
}
}
2020-07-19 15:47:30 -05:00
}
2020-07-17 21:36:12 -05:00
# encrypt a password with a provided or random salt
sub util_bcrypt {
my ( $ password , $ salt ) = @ _ ;
if ( ! defined $ salt ) {
$ salt = util_salt ( ) ;
}
my $ hash = bcrypt_hash ( {
key_nul = > 1 ,
cost = > 8 ,
salt = > $ salt
} , $ password ) ;
return join ( '-' , $ salt , en_base64 ( $ hash ) ) ;
}
# verify a plaintext password against a password hash
sub util_verify_password {
my ( $ password , $ crypted ) = @ _ ;
my ( $ salt ) = split ( /-/ , $ crypted ) ;
my $ check = util_bcrypt ( $ password , $ salt ) ;
return $ check eq $ crypted ;
}
# generate a random salt for bcrypt
sub util_salt {
my $ itoa64 = "./0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" ;
my $ salt = '' ;
2020-07-19 10:04:08 -05:00
$ salt . = substr ( $ itoa64 , int ( makerandom_itv ( Strength = > 0 , Upper = > 64 ) ) , 1 ) while length ( $ salt ) < 16 ;
2020-07-17 21:36:12 -05:00
return $ salt ;
}
# validate authorization header and return user from the database
sub util_get_authenticated {
my $ cgi = shift ;
my $ encoded = $ cgi - > http ( 'Authorization' ) ;
if ( ! defined $ encoded || $ encoded !~ /^Basic (\S+)/ ) {
return undef ;
}
$ encoded =~ s/^Basic // ;
my $ auth = undef ;
eval {
$ auth = decode_base64 ( $ encoded ) ;
} ;
if ( $@ || ! defined $ auth ) {
return undef ;
}
my ( $ email , $ password ) = split ( /:/ , $ auth , 2 ) ;
if ( ! defined $ email || ! defined $ password ) {
return undef ;
}
my $ user = util_get_user ( $ email ) ;
if ( ! defined $ user || ! $ user - > { 'verified' } ) {
return undef ;
}
return util_verify_password ( $ password , $ user - > { 'password' } )
? $ user
: undef ;
}
# generate an authorization token
sub util_token {
2020-07-19 10:04:08 -05:00
my $ length = shift ;
my $ chars = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" ;
2020-07-17 21:36:12 -05:00
my $ token = '' ;
2020-07-19 10:04:08 -05:00
$ token . = substr ( $ chars , int ( makerandom_itv ( Strength = > 0 , Upper = > 62 ) ) , 1 ) while length ( $ token ) < $ length ;
2020-07-17 21:36:12 -05:00
return $ token ;
}
# get a user from the database by email
sub util_get_user {
my $ email = shift ;
my $ sth = util_get_dbh ( ) - > prepare ( "SELECT email, password, token, strftime('%s', token_expires) AS token_expires, pw_token, strftime('%s', pw_token_expires) AS pw_token_expires, verified, strftime('%s', created) AS created, strftime('%s', updated) AS updated FROM users WHERE email=?" ) ;
$ sth - > execute ( $ email ) ;
2020-07-18 15:23:29 -05:00
die $ sth - > errstr if $ sth - > err ;
my $ user = $ sth - > fetchrow_hashref ;
return ( keys %$ user > 0 ) ? $ user : undef ;
2020-07-17 21:36:12 -05:00
}
# save a plan by email
sub util_save_plan {
my ( $ email , $ plan , $ signature ) = @ _ ;
2020-07-20 22:13:03 -05:00
my $ basename = catfile ( $ plan_dir , $ email ) ;
2020-07-17 21:36:12 -05:00
if ( defined $ plan ) {
2020-07-19 09:46:28 -05:00
open ( my $ plan_file , '>' , "$basename.plan" ) or die $! ;
2020-07-17 21:36:12 -05:00
flock ( $ plan_file , LOCK_EX ) ;
print $ plan_file $ plan ;
close ( $ plan_file ) ;
} elsif ( - f "$basename.plan" ) {
unlink "$basename.plan" ;
}
if ( defined $ plan && defined $ signature ) {
2020-07-23 18:29:56 -05:00
open ( my $ sig_file , '>' , "$basename.sig" ) or die $! ;
2020-07-17 21:36:12 -05:00
flock ( $ sig_file , LOCK_EX ) ;
2020-07-18 15:23:29 -05:00
print $ sig_file $ signature ;
2020-07-17 21:36:12 -05:00
close ( $ sig_file ) ;
2020-07-23 18:29:56 -05:00
} elsif ( - f "$basename.sig" ) {
unlink "$basename.sig" ;
2020-07-17 21:36:12 -05:00
}
# invalidate cache
2020-07-24 00:26:43 -05:00
$ _plancache - > remove ( $ email ) ;
2020-07-17 21:36:12 -05:00
}
# read a plan from cache or disk
sub util_read_plan {
my $ email = shift ;
2020-07-24 00:26:43 -05:00
my $ cached = $ _plancache - > get ( $ email ) ;
if ( ! defined $ cached ) {
2020-07-20 22:13:03 -05:00
my $ basename = catfile ( $ plan_dir , $ email ) ;
2020-07-17 21:36:12 -05:00
if ( - f "$basename.plan" ) {
2020-07-24 00:26:43 -05:00
$ cached = { } ;
2020-07-19 10:04:08 -05:00
open ( my $ plan_file , '<' , "$basename.plan" ) or die $! ;
2020-07-17 21:36:12 -05:00
flock ( $ plan_file , LOCK_SH ) ;
2020-07-19 09:28:37 -05:00
my $ mtime = ( stat ( $ plan_file ) ) [ 9 ] ;
2020-07-23 18:29:56 -05:00
my $ timestamp = HTTP::Date:: time2str ( $ mtime ) ;
2020-07-24 00:26:43 -05:00
$ cached - > { 'mtime' } = $ mtime ;
$ cached - > { 'timestamp' } = $ timestamp ;
2020-07-17 21:36:12 -05:00
local $/ ;
2020-07-24 00:26:43 -05:00
$ cached - > { 'plan' } = <$plan_file> ;
2020-07-17 21:36:12 -05:00
close ( $ plan_file ) ;
2020-07-23 18:29:56 -05:00
if ( - f "$basename.sig" ) {
open ( my $ sig_file , '<' , "$basename.sig" ) or die $! ;
2020-07-17 21:36:12 -05:00
flock ( $ sig_file , LOCK_SH ) ;
local $/ ;
2020-07-24 00:26:43 -05:00
$ cached - > { 'signature' } = <$sig_file> ;
2020-07-17 21:36:12 -05:00
close ( $ sig_file ) ;
}
2020-07-24 00:26:43 -05:00
$ _plancache - > set ( $ email , $ cached ) ;
2020-07-17 21:36:12 -05:00
}
}
2020-07-24 00:26:43 -05:00
return $ cached ;
2020-07-17 21:36:12 -05:00
}
# retrieve a plan by email
2020-07-16 23:55:59 -05:00
sub util_get_plan {
my $ email = shift ;
2020-07-17 21:36:12 -05:00
my ( $ local , $ domain ) = split ( /\@/ , $ email , 2 ) ;
if ( ! $ localdomains - > { $ domain } ) {
2020-07-24 00:26:43 -05:00
my $ cached = $ _srvcache - > get ( $ domain ) ;
if ( ! defined $ cached ) {
my $ dns = Net::DNS::Resolver - > new ( ) ;
my $ reply = $ dns - > query ( "_dotplan._tcp.$domain" , 'SRV' ) ;
if ( defined $ reply && $ reply - > answer > 0 ) {
my @ answer = $ reply - > answer ;
my ( undef , undef , $ port , $ svchost ) = split ( /\s+/ , $ answer [ 0 ] - > rdstring , 4 ) ;
$ svchost =~ s/\.$// ;
if ( $ hostname ne $ svchost ) {
$ cached = $ port == 80
? "http://$svchost"
2020-07-17 21:36:12 -05:00
: $ port == 443
2020-07-24 00:26:43 -05:00
? "https://$svchost"
: "https://$svchost:$port" ;
$ _srvcache - > set ( $ domain , $ cached ) ;
} else {
$ cached = 0 ;
}
2020-07-17 21:36:12 -05:00
} else {
2020-07-24 00:26:43 -05:00
$ cached = 0 ;
2020-07-17 21:36:12 -05:00
}
2020-07-24 00:26:43 -05:00
}
if ( $ cached ) {
my $ encoded = uri_escape ( $ email ) ;
return { redirect = > "$cached/plan/$encoded" } ;
2020-07-17 21:36:12 -05:00
} else {
return util_read_plan ( $ email ) ;
}
} else {
return util_read_plan ( $ email ) ;
}
}
2020-07-23 18:29:56 -05:00
# verify a plan signature with a pubkey
sub util_verify_plan {
my ( $ email , $ pubkey ) = @ _ ;
my $ basename = catfile ( $ plan_dir , $ email ) ;
if ( IPC::Run:: run [ 'minisign' , '-Vm' , "$basename.plan" , '-x' , "$basename.sig" , '-P' , "$pubkey" ] , '>' , '/dev/null' , '2>>' , '/dev/null' ) {
return 1 ;
}
return 0 ;
2020-07-17 21:36:12 -05:00
}
2020-07-16 20:48:53 -05:00
}
2020-07-17 23:57:40 -05:00
# only supports one optional argument -d to daemonize
2020-07-18 15:23:29 -05:00
my $ daemonize = $ ARGV [ 0 ] eq '-d' if @ ARGV == 1 ;
2020-07-17 21:36:12 -05:00
# start server and fork process as current user
my ( $ user , $ passwd , $ uid , $ gid ) = getpwuid $< ;
my $ group = getgrgid $ gid ;
if ( $ daemonize ) {
DotplanApi - > new ( $ server_port ) - > background (
pid_file = > $ pid_file ,
user = > $ user ,
group = > $ group
) ;
} else {
DotplanApi - > new ( $ server_port ) - > run (
pid_file = > $ pid_file ,
user = > $ user ,
group = > $ group
) ;
}