OpenVMS Source Code Demos
WWW_PASSWORD_CHANGE
1000 %title "www_password_change_xxx.bas"
%ident "version_105.2" ! <<<---***
declare string constant k_version = "105.2" , ! &
k_program = "www_password_change" !
!=========================================================================================================================
! Title : www_password_change_xxx.BAS
! Author : Neil Rieck ( mailto:n.rieck@bell.net - http://neilrieck.net )
! Created: 2013-01-09
! History:
! Ver Who When What
! --- --- ------ ---------------------------------------------------------------------------------------------------------
! 100 NSR 130109 1. original program
! NSR 130110 2. more work
! NSR 130114 3. more work
! 101 NSR 130115 1. started coding sys$setuai (the password change)
! 102 NSR 130115 1. inserted code to receive i/o directly from Apache (no external cgi glue required)
! 103 NSR 130121 1. added support for a second (verification) password called PASS3
! 2. now log all successful password changes
! 104 NSR 130206 1. started adding code to allow supervisor-oriented changes
! 130207 2. more work
! 3. ran this file through my source code formatter
! 4. inserted some cool JavaScript
! 130211 5. added a few more JavaScript bells and whistles (including blocking the submit button)
! 6. added a quick lookup to our profile-db (manager go-nogo test)
! 105 NSR 130212 1. now restrict profiled managers to only modifying profiled users
! 2. added some event logging
! NSR 130220 3. added code to present the correct text on error 9092 bf_105.3
! 4. added code to present the actual VMS error string bf_105.4
!=========================================================================================================================
option type=explicit ! cuz tricks are for kids...
declare string constant k_lock_fs$ = "csmis$dat:"+ k_program +".lck" ! lock file specification
declare string constant k_log_seq_fs$ = "csmis$dat:"+ k_program +".seq"! sequential log file specification
declare string constant k_log_idx_fs$ = "csmis$dat:"+ k_program +".idx"! indexed log file specification
declare long constant k_max_loop = 5 !
declare long constant k_max_params = 19 !
set no prompt !
!
! external declarations
!
%nolist
%include "starlet" %from %library "sys$library:basic$starlet" ! system services
%include "$ssdef" %from %library "sys$library:basic$starlet" ! ss$
%include "$syidef" %from %library "sys$library:basic$starlet" ! syi$
%include "$uaidef" %from %library "sys$library:basic$starlet" ! uai$
%include "$rmsdef" %from %library "sys$library:basic$starlet" ! rms$
%include "lib$routines" %from %library "sys$library:basic$starlet" ! lib$spawn
%include "$libdef" %from %library "sys$library:basic$starlet" ! eg. lib$_normal
%include "$iledef" %from %library "sys$library:basic$starlet" ! ile3$ (Item List Entry 3 structures)
%list
!
record ItemRec ! structure of item record
variant
case
group zero ! new code
ILE3 myILE3 ! from sys$library:basic$starlet
end group zero !
case
group one ! legacy code
word BuffLen ! length
word ItemCode ! code
long BuffAddr ! address of buffer
long RtnLenAdr ! address of word for returned length
end group one !
case
group two !
long List_Terminator !
long Junk1 !
long Junk2 !
end group two !
end variant !
end record ItemRec !
!
! home brewed functions
!
external string function wcsm_trnlnm (string, string) ! translate logical names
external string function wcsm_dt_stamp ! generates a timestamp: ccyymmddhhmmss
external string function fix_html_data (string) !
!
! local constants
!
declare string constant dq = '34'C ! double quote
declare string constant sq = '39'C ! single quote
declare string constant k_legal_pw_chars = "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_$"
declare string constant k_error_severity$ = "wseif???" ! warning, success, error, informational, etc.
!
! local variables
!
declare long handler_error% , ! &
display_blank_page% , ! &
blocked% , ! &
lock_count% , ! &
dvlp% , ! &
junk% , ! &
flags% , ! &
file_open91% , ! &
trace% , ! &
feedback% , ! &
status% , ! &
debug% , ! &
p_num% , ! &
amper_pos% , ! &
amper_remember% , ! &
equal_pos% , ! &
rc% , ! &
i%, j%, k% , ! &
param% , ! &
www_length% , ! &
data_length% , ! &
mgr_mode% , ! &
string out$ , ! &
stdin$ , ! &
fake_fs1$ , ! &
fake_fs2$ , ! &
query$ , ! &
node_name$ , ! &
msg$ , ! &
alt$ , ! &
dbg$ , ! &
url$ , ! &
junk$ , ! &
default_node$ , ! required during profile open &
noun$ , ! &
verb$ , ! &
user1$ , ! user &
pass1$ , ! old p/w &
pass2$ , ! new p/w &
pass3$ , ! confirm p/w &
user4$ , ! manager &
pass4$ , ! manager p/w &
request_method$ , ! &
http_host$ , ! &
path$ , ! &
path_info$ , ! &
path_translated$ , ! &
query_string$ , ! &
server_addr$ , ! &
server_port$ , ! &
remote_addr$ , ! &
remote_port$ , ! &
script_filename$ , ! &
script_name$ , ! &
script_uri$ , ! &
www_length$ !
!
dim string param$(k_max_params) !
!
! this stuff will be used in my system calls
!
declare basic$quadword uai_hashed_pw , ! &
pass1_hash , ! &
pass4_hash , ! &
quad_time , ! &
ItemRec myItems(9) , ! &
long rc_bits% , ! &
long uai_flags1% , ! &
uai_flags2% , ! &
word uai_salt , ! &
byte uai_encrytion_type% , ! &
uai_min_pwd_length% !
!
!====================================================================================================
! main (receive data from Apache)
!====================================================================================================
main: !
2000 margin #0, 1999888777 ! no implied EOL
!
! Apache Implementation Notes:
! 1. Most of the time, Apache will be set up to produce DCL symbols but it can be set up to use LOGICAL NAMES
! 2. Sometimes Apache will be set up to produce symbols (or logicals) with a prefix of "WWW_"
!
call lib$get_symbol("REQUEST_METHOD" ,request_method$ ) ! "POST" or "GET"
call lib$get_symbol("HTTP_HOST" ,http_host$ ) ! eg. kawc15.on.bell.ca
call lib$get_symbol("PATH" ,path$ ) ! eg. apache$root:[000000]
call lib$get_symbol("PATH_INFO" ,path_info$ ) ! always blank?
call lib$get_symbol("PATH_TRANSLATED" ,path_translated$ ) ! always blank?
call lib$get_symbol("QUERY_STRING" ,query_string$ ) !
call lib$get_symbol("SERVER_ADDR" ,server_addr$ ) ! eg. 142.180.39.15
call lib$get_symbol("SERVER_PORT" ,server_port$ ) ! eg. 80
call lib$get_symbol("SCRIPT_FILENAME" ,script_filename$ ) ! eg. /apache$documents/scripts/www_password_change.com
call lib$get_symbol("SCRIPT_NAME" ,script_name$ ) ! eg. /scripts/www_password_change
call lib$get_symbol("SCRIPT_URI" ,script_uri$ ) ! eg. https://kawc09.on.bell.ca/scripts/www_password_change
call lib$get_symbol("REMOTE_ADDR" ,remote_addr$ ) ! eg. may want this for logging purposes
call lib$get_symbol("REMOTE_PORT" ,remote_port$ ) ! eg. may want this for logging purposes
!
%let %noglue = 1 ! do not depend upon external glue
%if %noglue = 1 %then ! we will talk directly to Apache
!-----------------------------------------------------------------------
! this block of code will talk directly to Apache
!-----------------------------------------------------------------------
mat param$ = nul$ ! init parameter array
param% = 0 ! init
declare string a$, b$, p$, &
q_string$, html_data$ !
!
! support QUERY_STRING (but data is not used by this program)
!
select request_method$ !
case "GET", "POST" !
!
! Notes:
! 1. contrary to popular belief, it is possible to use QUERY_STRING in both GET + POST modes
! 2. URL: www.server.com/scripts/vms_basic_apache_demo?a=1&b=2&c=3&d=4
! |+--- argument list starts here
! +---- start of delimiter list
! 3. Example Argument list (form #1): a=1&b=2&c=3&d=4
! 4. Example Argument list (form #2): 1&2&3&4
!
q_string$ = query_string$ ! copy the Apache data
!~~~ p$ = "GET_" x (tack on this optional prefix)
if q_string$ <> "" then ! if query_string is not blank
q_string$ = fix_html_data(q_string$) !
!
get_next_qs_param:
param% = param% + 1 if param% < k_max_params ! prep to store the parameter
amper_pos% = pos(q_string$,"&",1) ! locate the amper delimiter
if amper_pos% = 0 then ! if no amper found
param$(param%) = p$+ q_string$ !
else !
param$(param%) = p$+ left$(q_string$, amper_pos%-1) ! save first segment
q_string$ = right$(q_string$,amper_pos%+1) ! isolate second segment
goto get_next_qs_param !
end if !
end if !
end select !
!
! read POSTed data from Apache
!
select request_method$ !
case "POST" ! someone clicked SUBMIT on form with method=POST
!
! we want to read from Apache's STDIN device
!
junk% = lib$get_symbol("CONTENT_LENGTH",www_length$) !
www_length% = integer(www_length$, long) !
!
stdin$ = WCSM_TrnLnm("SYS$COMMAND", "LNM$PROCESS_TABLE") !
junk% = pos(stdin$, "_", 0%) ! locate the underscore in the BG device
stdin$ = right$(stdin$, junk%+1%) !
!
when error in !
trace% = 1 !
open stdin$+":" for input as #1 ! connect to browser stream
trace% = 2 !
margin #1,0 ! disable implied EOL after 78 characters
handler_error% = 0 ! cool
use !
handler_error% = err ! oops
end when !
!
select handler_error% !
case 0 !
case else !
msg$ = &
"Error: "+ str$(handler_error%) +" during POST read"+cr+lf+ &
"Ert : "+ ert$(handler_error%) +cr+lf+ &
"Trace: "+ str$(trace%) +cr+lf
goto send_response ! exit thru here
end select !
!
get_more_data:
when error in !
trace% = 3 !
while 1 ! read until EOF
linput #1, a$ ! read directly from the browser
b$ = b$ + a$ ! question: won't this overflow at 32767?
cause error 50 if len(b$) > 32000 ! oops, b$ is getting rather large
next !
use !
handler_error% = err !
end when !
select handler_error% !
case 11 ! EOF
case 50 ! Exceeded 32000 byte limit
case 252 ! FILE ACP failure (input)
case else !
msg$ = &
"Error: "+ str$(handler_error%) +" during POST read"+cr+lf+ &
"Ert : "+ ert$(handler_error%) +cr+lf+ &
"Trace: "+ str$(trace%) +cr+lf
goto send_response ! exit thru here
end select !
!
data_length% = data_length% + len(b$) ! remember total bytes received
html_data$ = fix_html_data(b$) if b$ <> "" !
!
%let %debugdata = 0 ! disabled for now
%if %debugdata = 1 %then !
msg$ = html_data$ !
goto send_response !
%end %if !
!
!~~~ p$ = "POST_" x (tack on this optional prefix)
if html_data$ <> "" then ! if query_string is not blank
!
get_next_param:
param% = param% + 1 if param% < k_max_params ! prep to store the parameter
amper_pos% = pos(html_data$,"&",1) ! locate the amper delimiter
if amper_pos% = 0 then ! if no amper found (must be on the last param)
param$(param%) = p$+ html_data$ !
else !
amper_remember% = amper_pos% ! save for buffer trimming
param$(param%) = p$+ left$(html_data$, amper_pos%-1) ! save first segment
html_data$ = right$(html_data$,amper_pos%+1) ! isolate second segment
goto get_next_param !
end if !
end if !
!
! future work (requires development for POSTs over 32767 bytes)
!
%let %future = 0 ! disabled for now
%if %future = 1 %then !
if www_length% > data_length% then ! if we haven't received everything
if amper_remember% > 0 then ! if non-zero
html_data$ = right$(html_data$,amper_remember%-1) ! reduce size of html_data$
amper_remember% = 0 ! zap
goto get_more_data ! loop back
end if !
end if
%end %if
!
display_blank_page% = 0 !
case "GET" !
display_blank_page% = 1 !
end select !
!
! let's scan the POSTed params and transfer them to variables
!
for i% = 1 to param% !
equal_pos% = pos(param$(i%),"=",1) !
if equal_pos% = 0 then !
noun$ = param$(i%) !
verb$ = "" !
else !
noun$ = left$ (param$(i%), equal_pos%-1) !
verb$ = right$(param$(i%), equal_pos%+1) !
end if !
!
select noun$ !
case "USER1" ! USER NAME
user1$ = verb$ !
case "PASS1" ! current p/w
pass1$ = verb$ !
case "PASS2" ! new p/w
pass2$ = verb$ !
case "PASS3" ! verify p/w
pass3$ = verb$ !
case "USER4" ! MANAGER NAME
user4$ = verb$ !
case "PASS4" ! manager p/w
pass4$ = verb$ !
case "DEBUG","debug","HACK","hack" !
debug% = 1 !
end select !
next i% !
if debug% = 1 then !
msg$ = "-i-Apache Symbols:"+ &
"<br>REQUEST_METHOD: "+ request_method$ +&
"<br>HTTP_HOST: "+ http_host$ +&
"<br>PATH: "+ path$ +&
"<br>PATH_INFO: "+ path_info$ +&
"<br>PATH_TRANSLATED: "+path_translated$ +&
"<br>QUERY_STRING: "+ query_string$ +&
"<br>SERVER_ADDR: "+ server_addr$ +&
"<br>SERVER_PORT: "+ server_port$ +&
"<br>SCRIPT_FILENAME: "+script_filename$ +&
"<br>SCRIPT_NAME: "+ script_name$
goto send_response !
end if !
%else ! an external glue file is required
!-----------------------------------------------------------------------
! this block of code requires that our CGI script first called a glue program
! which will read POSTed HTML data then convert it to DCL symbols
!
! Note: our cgi glue program adds the prefix "FORM_FLD_" to all variables
!-----------------------------------------------------------------------
call lib$get_symbol("REQUEST_METHOD",request_method$) !
print "-i-REQUEST_METHOD: "+request_method$ if debug% > 0 !
select request_method$ !
case "POST" ! "POST" via SUBMIT button
call lib$get_symbol("FORM_FLD_USER1" ,user1$) !
call lib$get_symbol("FORM_FLD_PASS1" ,pass1$) !
call lib$get_symbol("FORM_FLD_PASS2" ,pass2$) !
call lib$get_symbol("FORM_FLD_PASS3" ,pass3$) !
call lib$get_symbol("FORM_FLD_USER4" ,user4$) !
call lib$get_symbol("FORM_FLD_PASS4" ,pass4$) !
if debug% > 0 then !
print "-i-FORM_FLD_USER1>"+ user1$ +"<" !
print "-i-FORM_FLD_PASS1>"+ pass1$ +"<" !
print "-i-FORM_FLD_PASS2>"+ pass2$ +"<" !
print "-i-FORM_FLD_PASS3>"+ pass3$ +"<" !
print "-i-FORM_FLD_USER4>"+ user4$ +"<" !
print "-i-FORM_FLD_PASS4>"+ pass4$ +"<" !
sleep 1 !
end if !
display_blank_page% = 0 !
case else ! "GET" via the URL string
display_blank_page% = 1 !
end select !
%end %if
!=======================================================================
! what is the user trying to do? GET or POST?
!=======================================================================
main2:
rc% = lib$getsyi( syi$_nodename,,node_name$ ) !
!~~~ node_name$ = edit$(node_name$,32+2) x superfluous since always up case
select node_name$ !
case "KAWC15", "KAWC96" ! my production platforms
blocked% = 0 ! not blocked
case "KAWC09" ! my development platform
blocked% = 0 ! not blocked
dvlp% = 1 !
case else !
blocked% = 1 ! blocked by default
end select !
fake_fs1$ = "file"+ wcsm_dt_stamp +".txt" ! use this in MIME headers bf_108.3
fake_fs2$ = "file"+ wcsm_dt_stamp +".html" ! use this in MIME headers bf_108.3
junk$ = WCSM_TrnLnm("CSMIS$DEBUG", "LNM$PROCESS_TABLE") ! this may be set by the CGI
junk$ = "0" if junk$ = "" !
when error in !
debug% = integer(junk$) ! 0=Off, 1=On(basic), 2=On(extreme) <<<---***
use !
debug% = 0 !
end when !
if debug% > 0 then !
print "Status: 200" ! start of HTML response header
print 'Cache-Control: no-cache, no-store' ! this is better than HTML META
print "Content-type: text/plain" !
print "Content-disposition: inline; filename="+ dq + fake_fs1$ +dq ! bf_108.3
print "" ! end of HTML response header
print "-i-program: "+ k_program +"."+ k_version !
print "-i-debug level: "+str$(debug%) !
end if !
!
! web implementation notes:
! 1. the first time through here we use GET mode so will send back a web page
! 2. when the button is clicked, we use POST mode and read the HTML data
! 3. let's hope the system admin set this up to only allow HTTPS
!
call sys$setpri(,,3% by value,,,) ! drop back to below interactive default
!
! <<< do inits >>>
!
junk% = pos(script_uri$,"//",1) ! https://kawc09.on.bell.ca/scripts/www_password_change
if junk% = 0 then !
url$ = script_uri$ ! use whole uri
else !
url$ = right$(script_uri$,junk%+2) !
end if !
!
goto process_http_request if display_blank_page% = 0 ! must have done HTTP-POST so jump
!-----------------------------------------------------------------------
! user must have done HTTP-GET so...
! create a blank page, display it, then exit
!-----------------------------------------------------------------------
out$ = 'Status: 200' +cr+lf+ ! good response &
'Cache-Control: no-cache, no-store' +cr+lf+ ! better than HTML meta &
'Content-type: text/html' +cr+lf+ ! &
'Content-disposition: inline; filename='+ dq + fake_fs2$ +dq +cr+lf ! &
+cr+lf+ ! end of mime BLOCK &
'<!DOCTYPE html>' +cr+lf+ ! &
'<html lang="en-us">' +cr+lf+ ! &
'<head>' +cr+lf+ ! &
'<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">' +cr+lf+ ! &
'<title>ICSIS Password Change</title>' +cr+lf+ ! &
'<style type="text/css">' +cr+lf+ ! &
' body { font-family: Calibri, "Trebuchet MS", Verdana, sans-serif;' + ! &
' font-size:12pt; background-color: #fff; }' +cr+lf+ ! &
' .title { color: red; font-size:14pt; font-weight:bold }' +cr+lf+ ! &
' .copy { color: black; font-size:13pt; font-weight:bold }' +cr+lf+ ! &
' a:link { color: blue }' +cr+lf+ ! &
' a:visited { color: blue }' +cr+lf+ ! &
' a:hover { color: blue; background-color: #ffa; cursor: pointer }' +cr+lf+ ! &
' a:active { color: blue }' +cr+lf+ ! &
' pre { font-weight:700 }' +cr+lf+ ! &
' form { font-family: "Courier New", Courier, monospace; font-size:12pt; color: black }' +cr+lf+ ! &
' input { font-family: "Courier New", Courier, monospace; font-size:12pt; color: black }' +cr+lf+ ! &
' .wb { background-color: #00f; color: #fff; font-weight: bold }' +cr+lf+ ! white-on-blue &
' .wr { background-color: #f00; color: #fff; font-weight: bold }' +cr+lf+ ! white-on-red &
' .y { background-color: #ff0; font-weight: bold }' +cr+lf+ ! yellow bold &
' .g { background-color: #9e9; font-weight: bold }' +cr+lf+ ! green bold &
' .b { color: blue }' +cr+lf+ ! blue &
' .r { color: red }' +cr+lf+ ! blue &
' .yellow { background-color: #ff0 }' +cr+lf+ ! yellow &
'</style>' +cr+lf+ ! &
'<script type="text/javascript">' +cr+lf+ ! &
'var gbl_mode = 0; // init' +cr+lf+ ! &
'function flip(){' +cr+lf+ ! &
' if (document.getElementById("USER4").value!=""){' +cr+lf+ ! &
' document.getElementById("PASS1").value="";' +cr+lf+ ! &
' document.getElementById("PASS1").style.backgroundColor="#d8d8d8";' +cr+lf+ ! &
' document.getElementById("PASS1").readOnly=true;' +cr+lf+ ! same as disabled &
' document.getElementById("PASS4").style.backgroundColor="#ffffff";' +cr+lf+ ! &
' document.getElementById("PASS4").readOnly=false;' +cr+lf+ ! same as enabled &
' gbl_mode = 1; // manager' +cr+lf+ ! &
' }else{' +cr+lf+ ! &
' document.getElementById("PASS4").value="";' +cr+lf+ ! &
' document.getElementById("PASS4").style.backgroundColor="#d8d8d8";' +cr+lf+ ! &
' document.getElementById("PASS4").readOnly=true;' +cr+lf+ ! same as disabled &
' document.getElementById("PASS1").style.backgroundColor="#ffffff";' +cr+lf+ ! &
' document.getElementById("PASS1").readOnly=false;' +cr+lf+ ! same as enabled &
' gbl_mode = 2; // user' +cr+lf+ ! &
' }' +cr+lf+ ! &
' validate(); // display messages' +cr+lf+ ! &
'}' +cr+lf+ ! &
'function validate(){' +cr+lf+ ! &
' var gonogo=1; // init to go' +cr+lf+ ! &
' var p1=document.getElementById("PASS1").value;' +cr+lf+ ! &
' var p2=document.getElementById("PASS2").value;' +cr+lf+ ! &
' var p3=document.getElementById("PASS3").value;' +cr+lf+ ! &
' var p4=document.getElementById("PASS4").value;' +cr+lf+ ! &
' var u1=document.getElementById("USER1").value;' +cr+lf+ ! &
' var u4=document.getElementById("USER4").value;' +cr+lf+ ! &
' document.getElementById("MSGP1").innerHTML="";' +cr+lf+ ! &
' document.getElementById("MSGP2").innerHTML="";' +cr+lf+ ! &
' document.getElementById("MSGP3").innerHTML="";' +cr+lf+ ! &
' document.getElementById("MSGP4").innerHTML="";' +cr+lf+ ! &
' document.getElementById("MSGU1").innerHTML="";' +cr+lf+ ! &
' document.getElementById("MSGU4").innerHTML="";' +cr+lf+ ! &
' document.getElementById("DEBUG1").innerHTML="";' +cr+lf+ ! &
' document.getElementById("DEBUG2").innerHTML="";' +cr+lf+ ! &
' switch(gbl_mode){' +cr+lf+ ! &
' case 1: // manager mode' +cr+lf+ ! &
' if (p4.length<6){' +cr+lf+ ! &
' document.getElementById("MSGP4").innerHTML="too small";' +cr+lf+ ! &
' gonogo=0;' +cr+lf+ ! &
' }' +cr+lf+ ! &
' if (u4.length<4){' +cr+lf+ ! &
' document.getElementById("MSGU4").innerHTML="too small";' +cr+lf+ ! &
' gonogo=0;' +cr+lf+ ! &
' }' +cr+lf+ ! &
' if (u1==u4){' +cr+lf+ ! &
' document.getElementById("MSGU4").innerHTML="Error, MANAGER same as USER";' +cr+lf+ ! &
' gonogo=0;' +cr+lf+ ! &
' }' +cr+lf+ ! &
' break;' +cr+lf+ ! &
' case 2: // user mode' +cr+lf+ ! &
' if (u1.length<4){' +cr+lf+ ! &
' document.getElementById("MSGU1").innerHTML="too small";' +cr+lf+ ! &
' gonogo=0;' +cr+lf+ ! &
' }' +cr+lf+ ! &
' if (p1.length<6){' +cr+lf+ ! &
' document.getElementById("MSGP1").innerHTML="too small";' +cr+lf+ ! &
' gonogo=0;' +cr+lf+ ! &
' }' +cr+lf+ ! &
' break;' +cr+lf+ ! &
' default:' +cr+lf+ ! &
' gonogo=0;' +cr+lf+ ! &
' break;' +cr+lf+ ! &
' }' +cr+lf+ ! &
' // code common to all modes' +cr+lf+ ! &
' if (p2.length<6){' +cr+lf+ ! &
' document.getElementById("MSGP2").innerHTML="too small";' +cr+lf+ ! &
' gonogo=0;' +cr+lf+ ! &
' }' +cr+lf+ ! &
' if (p3.length<6){' +cr+lf+ ! &
' document.getElementById("MSGP3").innerHTML="too small";' +cr+lf+ ! &
' gonogo=0;' +cr+lf+ ! &
' }' +cr+lf+ ! &
' if ((p1==p2)&&(p1.length>0)){' +cr+lf+ ! &
' document.getElementById("MSGP2").innerHTML="error: same as CURRENT PASSWORD";' +cr+lf+ ! &
' gonogo=0;' +cr+lf+ ! &
' }' +cr+lf+ ! &
' if ((p2!=p3)&&(p3.length>0)){' +cr+lf+ ! &
' document.getElementById("MSGP3").innerHTML="error: different than NEW PASSWORD";'+cr+lf+ ! &
' gonogo=0;' +cr+lf+ ! &
' }' +cr+lf+ ! &
' document.getElementById("DEBUG1").innerHTML="Mode: "+gbl_mode;' +cr+lf+ ! &
' if (gonogo==0){' +cr+lf+ ! &
' document.getElementById("B1").style.backgroundColor="#ff0000";' +cr+lf+ ! red &
' return(false);' +cr+lf+ ! block submit &
' }else{' +cr+lf+ ! &
' document.getElementById("B1").style.backgroundColor="#00ff00";' +cr+lf+ ! green &
' return(true);' +cr+lf+ ! allow submit &
' };' +cr+lf+ ! &
'}' +cr+lf+ ! &
'</script>' +cr+lf+ ! &
'</head><body onload="flip();">' +cr+lf+ ! &
'<noscript><p>Oops, JavaScript is not enabled in your browser</p></noscript>' +cr+lf+ ! &
'<span class="title">ICSIS Password Change Tool</span>' + ! &
'<span class="copy"> Copyright © 2000-2013, Bell Canada</span>' +cr+lf+ ! &
'<form class="font14" id="FORM1" name="FORM1" method="POST"' + ! &
' action="/scripts/'+ k_program +'" >' + ! &
'<p>' + ! &
'<b>User Name </b>' + ! Line #1 &
' <input size="12" type="text" name="USER1" id="USER1" onkeyup="flip();">' + ! &
' <span name="MSGU1" id="MSGU1"></span><br>' +cr+lf+ ! &
'<b>Current Password</b>' + ! Line #2 &
' <input size="32" type="password" name="PASS1" id="PASS1" onkeyup="validate();">' + ! &
' <span name="MSGP1" id="MSGP1"></span><br>' +cr+lf+ ! &
'<b>New Password</b>' + ! Line #3 &
' <input size="32" type="password" name="PASS2" id="PASS2" onkeyup="validate();">' + ! &
' <span name="MSGP2" id="MSGP2"></span><br>' +cr+lf+ ! &
'<b>Verify Password</b>' + ! Line #4 &
' <input size="32" type="password" name="PASS3" id="PASS3" onkeyup="validate();">' + ! &
' <span name="MSGP3" id="MSGP3"></span><br>' +cr+lf+ ! &
' <input type="submit" value="Change" name="B1" id="B1" ' + ! &
' onclick="JavaScript:return validate();">'+ ! enable/disable submit &
'<input type="hidden" name="hidden_name" value="web"></p>' + ! &
'<pre>Caveat: ICSIS user names are of the form xx_xxxxxx' +cr+lf+ ! &
' passwords must be letters and or numbers only' +cr+lf+ ! &
' passwords must be a least 8 characters long' +cr+lf+ ! &
' nothing is case sensitive (for now)' +cr+lf+ ! &
' this process always invokes a 5 second delay for security purposes' +cr+lf+ ! &
' all activities (including your I/P address) are logged' +cr+lf+ ! &
'</pre><hr>' + ! &
'<b>=== For use by managers changing passwords for their employees ===</b>' + ! &
'<br><br>' +cr+lf+ ! &
'<b>Manager Name </b>' + ! Line #5 &
' <input size="12" type="text" name="USER4" id="USER4" onkeyup="flip();">' +cr+lf+ ! &
' <span name="MSGU4" id="MSGU4"></span><br>' +cr+lf+ ! &
'<b>Manager Password</b>' + ! Line #6 &
' <input size="32" type="password" name="PASS4" id="PASS4" onkeyup="validate();">' + ! &
' <span name="MSGP4" id="MSGP4"></span><br>' +cr+lf+ ! &
'</form><hr>' + ! &
'<span name="DEBUG1" id="DEBUG1"></span><br>' + ! &
'<span name="DEBUG2" id="DEBUG2"></span><br>' + ! &
'<p><img src="/images/valid-html401.gif" ' + ! &
'alt="Valid HTML 4.01 Transitional" style="border:0; width:88px">' + ! &
'</p></body></html>' !
print out$ ! bam...
!
goto fini !
!=======================================================================
! process the user request
!=======================================================================
main3:
process_http_request: !
!
! okay, now for some basic sanity tests
!
if blocked% = 1 then !
msg$ = "-e-password changes are blocked on this node" !
goto send_response !
end if !
!
! Caveat: starting with OpenVMS-7.3-2 (I think), passwords can be case sensitive.
! So we must test UAI$M_PWDMIX to see if we should also upcase PASS1 and PASS2
!
user1$ = edit$(user1$ ,32+2) ! upcase, no w/s
pass1$ = edit$(pass1$ ,128+8) ! no trailing w/s, no leading w/s
pass2$ = edit$(pass2$ ,128+8) ! no trailing w/s, no leading w/s
pass3$ = edit$(pass3$ ,128+8) ! no trailing w/s, no leading w/s
!
user4$ = edit$(user4$ ,32+2) ! upcase, no w/s
pass4$ = edit$(pass4$ ,128+8) ! no trailing w/s, no leading w/s
!
if (user1$ = user4$) and (user1$ <> "") then !
msg$ = "-e-Error, MANAGER NAME same as USER NAME" !
goto send_response !
end if !
!-----------------------------------------------------------------------
! test the manager name and p/w first (added with version 104.1)
!-----------------------------------------------------------------------
mgr_mode% = 0 ! bf_104.1
select len(user4$) ! test MANAGER name
case 0 ! if none...
pass4$ = "" ! then zap this just in case
case < 4 !
msg$ = "-e-Error, MANAGER NAME is too small" !
case else !
select user4$ !
case "NEIL","STEVE","DAVE","KARIM" !
mgr_mode% = 1 ! enable manager logic below
pass1$ = "" ! zap this just in case
select len(pass4$) !
case 0 !
msg$ = "-e-Error, MANAGER PASSWORD is blank" !
case < 4 ! a system manager might have set it this short
msg$ = "-e-Error, MANAGER PASSWORD is too small"!
case > UAI$C_MAX_PWD_LENGTH !
msg$ = "-e-Error, MANAGER PASSWORD is too large"!
end select !
case else !
%let %externaldb = 1 ! 1=enable, 0=none, 1=ICSIS, 2=other
%if %externaldb = 0 %then ! -------------------------------------------------
msg$ = "-e-Error, MANAGER: "+ user4$ +" was not found in profile-db" ! lie to hackers
%end %if ! -------------------------------------------------
!
%if %externaldb = 1 %then ! -------------------------------------------------
! ICSIS System Notes:
! 1) The ICSIS system requires profiled user names of the form "xy_zzzzzzz"
! (where x and y are first and middle initials; people without a middle name get "X")
! 2) The key#0 of the current version of profile-db is based on surname
! 3) We will only allow a profiled manager to change the VMS password of a profiled user
! 4) A profiled manager will not be allowed to change the VMS password of accounts like SYSTEM + DECNET.
!
%include "[.fil]profiledb_92.rec" ! record map declarations
!
! is the MANAGER NAME profiled in ICSIS?
!
when error in !
%include "[.fil]profiledb_92_open91.opn" ! open the file
if mid$(user4$,3,1)="_" then ! our profiled names are of the form: xy_zzzzzzz
junk$ = right$(user4$,4) ! get profiled surname
else !
cause error 155 ! RNF
end if !
find #92, key#0 ge junk$, regardless ! set key of reference (w/o lock)
while 1 !
get #92, regardless ! read a record w/o lock
if edit$(d91_last_name,32+2) <> junk$ then ! if we lost our key of reference...
cause error 155 ! ...then exit with RNF
end if !
!
! remember, there may be more than one "SMITH"
!
if user4$ = edit$(d91_csmis_id,32+2) then ! if we found the specified user
if d91_title = "MGR" then ! if this user is also a manager
handler_error% = 0 ! then we'll allow it
goto exit_profile_search_mgr ! so jump
else !
cause error 50 ! pretend it is a DATA FORMAT ERROR
end if !
end if !
next !
use !
handler_error% = err ! oops
end when !
!
exit_profile_search_mgr: !
select handler_error% !
case 0 !
case 50 !
msg$ = "-e-Error, MANAGER: "+ user4$ +" is not a manager"
case 155 !
msg$ = "-e-Error, MANAGER: "+ user4$ +" was not found in profile-db"
case else !
msg$ = "-e-Error, MANAGER: "+ user4$ +" caused BASIC error :"+ str$(handler_error%)
end select !
!
! is USER NAME (target of action by MASTER NAME) profiled in ICSIS?
!
when error in !
if mid$(user1$,3,1)="_" then ! our profiled names are of the form: xy_zzzzzzz
junk$ = right$(user1$,4) ! get profiled surname
else !
cause error 155 ! RNF
end if !
find #92, key#0 ge junk$, regardless ! set key of reference (w/o lock)
while 1 !
get #92, regardless ! read a record w/o lock
if edit$(d91_last_name,32+2) <> junk$ then ! if we lost our key of reference...
cause error 155 ! ...then exit with RNF
end if !
!
! remember, there may be more than one "SMITH"
!
if user1$ = edit$(d91_csmis_id,32+2) then ! if we found the specified user
if d91_title <> "MGR" then ! if this user is NOT a manager
handler_error% = 0 ! then we'll allow it
goto exit_profile_search_usr ! so jump
else !
cause error 50 ! pretend it is a DATA FORMAT ERROR
end if !
end if !
next !
use !
handler_error% = err ! oops
end when !
!
exit_profile_search_usr: !
select handler_error% !
case 0 !
case 50 !
msg$ = "-e-Error, USER: "+ user1$ +" is a manager (peers cannot change peer authentication)"
case 155 !
msg$ = "-e-Error, USER: "+ user1$ +" was not found in profile-db"
case else !
msg$ = "-e-Error, USER: "+ user1$ +" caused BASIC error :"+ str$(handler_error%)
end select !
%end %if !
!
%if %externaldb = 2 %then ! -------------------------------------------------
insert your own code here
%end %if
end select ! -------------------------------------------------
if user1$ = user4$ then !
msg$ = "-e-Error, MANAGER NAME same as USER NAME" !
end if !
end select !
goto send_response if msg$ <> "" !
!
if mgr_mode% = 1 then
!
! prep for call to sys$getuai (fetch hashed password of manager)
!
myItems(0)::BuffLen = 4 ! size of uai_encrytion_type% in bytes
myItems(0)::ItemCode = UAI$_ENCRYPT !
myItems(0)::BuffAddr = loc(uai_encrytion_type%) ! addr of uai_encrytion_type%
myItems(0)::RtnLenAdr = 0 ! location of bytes returned (don't care)
!
myItems(1)::BuffLen = 8 ! size of hashed_password in bytes (64-bit)
myItems(1)::ItemCode = UAI$_PWD !
myItems(1)::BuffAddr = loc(uai_hashed_pw) ! addr of hashed_password
myItems(1)::RtnLenAdr = 0 ! location of bytes returned (don't care)
!
myItems(2)::BuffLen = 2 ! size of uai_salt in bytes
myItems(2)::ItemCode = UAI$_SALT !
myItems(2)::BuffAddr = loc(uai_salt) ! addr of uai_salt
myItems(2)::RtnLenAdr = 0 ! location of bytes returned (don't care)
!
myItems(3)::BuffLen = 4 ! size of uai_flags1 in bytes (UAI$S_FLAGS)
myItems(3)::ItemCode = UAI$_FLAGS !
myItems(3)::BuffAddr = loc(uai_flags1%) ! addr of uai_flags1
myItems(3)::RtnLenAdr = 0 ! location of bytes returned (don't care)
!
myItems(4)::List_Terminator = 0 !
!
! SYS$GETUAI [nullarg] ,[contxt] ,usrnam ,itmlst ,[nullarg] ,[nullarg] ,[nullarg]
!
rc% = sys$getuai(,,user4$,myItems(0),,,) !
rc_bits% = (rc% and 7%) !
if rc_bits% <> 1% then !
select rc% !
case RMS$_RNF !
msg$ = "-e-Error, MANAGER NAME and/or PASSWORD are invalid"
case else !
msg$ = "-e-getuai-"+ mid$(k_error_severity$, rc_bits%+1, 1) +"-rc: "+str$(rc%)
end select !
goto send_response !
end if !
!
if (uai_flags1% and UAI$M_PWDMIX) = 0 then ! if mixed-case passwords are not allowed
pass4$ = edit$(pass4$ ,32) ! upcase
end if !
!
! now get a hash for PASS4 and make sure it matches the hashed password retrieved from sys$getuai
!
! SYS$HASH_PASSWORD pwd ,alg ,[salt] ,usrnam ,hash
!
rc% = sys$hash_password(pass4$,uai_encrytion_type%,uai_salt,user4$,pass4_hash)
rc_bits% = (rc% and 7%) !
if rc_bits% <> 1% then !
msg$ = "-e-hash_password1-"+ mid$(k_error_severity$, rc_bits%+1%, 1%) +"-rc: "+str$(rc%)
goto send_response !
end if !
!
! do hashes match?
!
if pass4_hash <> uai_hashed_pw then ! NO
msg$ = "-e-Error, MANAGER NAME and/or PASSWORD are invalid" !
goto send_response !
end if !
end if !
!-----------------------------------------------------------------------
! pre-104 code resumes
!-----------------------------------------------------------------------
select len(user1$) !
case 0 !
msg$ = "-e-Error, USER NAME is blank" !
case < 4 !
msg$ = "-e-Error, USER NAME is to small" !
end select !
goto send_response if msg$ <> "" !
!
select edit$(user1$,32+2) ! upcase for tests
case "SYSTEM","DEFAULT","MANAGER","SSHD","DECNET" !
msg$ = "-e-Error, you can't user this web tool to modify the password of a reserved account"
goto send_response !
case else !
junk$ = edit$(user1$,32+2) ! upcase for tests
junk% = 0 ! init test
junk% = 1 if pos(junk$,"SSH" ,1) !
junk% = 1 if pos(junk$,"SHARE" ,1) !
junk% = 1 if pos(junk$,"SERVER" ,1) !
if junk% = 1 then !
msg$ = "-e-Error, you can't user this web tool to modify the password of a reserved account"
goto send_response !
end if !
end select !
!
! in user mode we first validate USER1/PASS1
!
if mgr_mode% = 0 then ! USER
select len(pass1$) !
case 0 !
msg$ = "-e-Error, CURRENT PASSWORD is blank" !
case < 4 ! a system manager might have set it this short
msg$ = "-e-Error, CURRENT PASSWORD is too small" !
case > UAI$C_MAX_PWD_LENGTH !
msg$ = "-e-Error, CURRENT PASSWORD is too large" !
end select !
else ! MANAGER
end if !
goto send_response if msg$ <> "" !
!-----------------------------------------------------------------------
! for security reasons, we only allow one transaction at a time
! so apply an exclusive lock on a specific file (others can wait)
!-----------------------------------------------------------------------
lock_count% = 0 ! init
!
lock_loop: !
sleep 1 ! 1 second delay to prevent probing
lock_count% = lock_count% + 1 ! incr
if lock_count% >= k_max_loop then !
msg$ = "-e-Error, could not acquire a lock within "+str$(k_max_loop)+" seconds. Please try again later"
goto send_response ! print and exit
end if !
!
map(xyz)string d99_ccyymmddhhmmss = 14 , ! (future use) &
long d99_transaction_counter% ! (future use)
!
when error in !
open k_lock_fs$ as #99 ! &
,access modify ! we want full access &
,allow none ! no one else may access this (for now) &
,organization relative ! &
,map xyz !
get #99, record 1 ! get the record
d99_ccyymmddhhmmss = wcsm_dt_stamp ! update the time stamp
update #99 ! write back (but the file is still locked)
handler_error% = 0 ! cool
use !
handler_error% = err ! oops
end when !
!
select handler_error% !
case 0 ! lock was applied
case 154, 138, 19 ! various lock-related errors
goto lock_loop !
case 155 ! RNF
d99_ccyymmddhhmmss = wcsm_dt_stamp ! for future use
d99_transaction_counter% = 1 ! for future use
when error in !
put #99, record 1 !
handler_error% = 0 ! cool
use !
handler_error% = err !
msg$ = "-e-Error: "+str$(handler_error%)+" during lock file mtce 123"
end when !
goto lock_loop if msg$ = "" !
case 160 ! File attributes not matched
close #99 !
when error in !
kill k_lock_fs$ ! delete the file
handler_error% = 0 ! cool
use !
handler_error% = err ! oops
msg$ = "-e-Error: "+str$(handler_error%)+" during lock file mtce 456"
end when !
goto lock_loop if msg$ = "" !
case else !
msg$ = "-e-Error, application error "+ str$(handler_error%) !
end select !
goto send_response if msg$ <> "" ! print and exit
!-----------------------------------------------------------------------
! processing continues
!-----------------------------------------------------------------------
!
! prep for call to sys$getuai (fetch hashed password of desired user)
!
myItems(0)::BuffLen = 4 ! size of uai_encrytion_type% in bytes
myItems(0)::ItemCode = UAI$_ENCRYPT !
myItems(0)::BuffAddr = loc(uai_encrytion_type%) ! addr of uai_encrytion_type%
myItems(0)::RtnLenAdr = 0 ! location of bytes returned (don't care)
!
myItems(1)::BuffLen = 8 ! size of hashed_password in bytes (64-bit)
myItems(1)::ItemCode = UAI$_PWD !
myItems(1)::BuffAddr = loc(uai_hashed_pw) ! addr of hashed_password
myItems(1)::RtnLenAdr = 0 ! location of bytes returned (don't care)
!
myItems(2)::BuffLen = 2 ! size of uai_salt in bytes
myItems(2)::ItemCode = UAI$_SALT !
myItems(2)::BuffAddr = loc(uai_salt) ! addr of uai_salt
myItems(2)::RtnLenAdr = 0 ! location of bytes returned (don't care)
!
myItems(3)::BuffLen = 1 ! size of uai_min_pwd_length in bytes
myItems(3)::ItemCode = UAI$_PWD_LENGTH !
myItems(3)::BuffAddr = loc(uai_min_pwd_length%) ! addr of uai_min_pwd_length
myItems(3)::RtnLenAdr = 0 ! location of bytes returned (don't care)
!
myItems(4)::BuffLen = 4 ! size of uai_flags1 in bytes (UAI$S_FLAGS)
myItems(4)::ItemCode = UAI$_FLAGS !
myItems(4)::BuffAddr = loc(uai_flags1%) ! addr of uai_flags1
myItems(4)::RtnLenAdr = 0 ! location of bytes returned (don't care)
!
myItems(5)::List_Terminator = 0 !
!
! SYS$GETUAI [nullarg] ,[contxt] ,usrnam ,itmlst ,[nullarg] ,[nullarg] ,[nullarg]
!
rc% = sys$getuai(,,user1$,myItems(0),,,) !
rc_bits% = (rc% and 7%) !
if rc_bits% <> 1% then !
select rc% !
case RMS$_RNF ! USER not found
msg$ = "-e-Error, USER NAME and/or CURRENT PASSWORD are invalid" ! but don't tip off hackers
case else !
msg$ = "-e-getuai-"+ mid$(k_error_severity$, rc_bits%+1, 1) +"-rc: "+str$(rc%)
end select !
goto send_response !
end if !
!
if (uai_flags1% and UAI$M_PWDMIX) = 0 then ! if mixed-case passwords are not allowed
pass1$ = edit$(pass1$ ,32) ! upcase
pass2$ = edit$(pass2$ ,32) ! upcase
pass3$ = edit$(pass3$ ,32) ! upcase
end if !
!
! now get a hash for PASS1 and make sure it matches the hashed password retrieved from sys$getuai
!
! SYS$HASH_PASSWORD pwd ,alg ,[salt] ,usrnam ,hash
!
if mgr_mode% = 0 then ! USER
rc% = sys$hash_password(pass1$,uai_encrytion_type%,uai_salt,user1$,pass1_hash)
rc_bits% = (rc% and 7%) !
if rc_bits% <> 1% then !
msg$ = "-e-hash_password1-"+ mid$(k_error_severity$, rc_bits%+1%, 1%) +"-rc: "+str$(rc%)
goto send_response !
end if !
!
! do hashes match?
!
if pass1_hash <> uai_hashed_pw then ! NO
msg$ = "-e-Error, USER NAME and/or CURRENT PASSWORD are invalid"!
goto send_response !
end if !
!-----------------------------------------------------------------------
! PASS1 is valid (so now test some other stuff)
!-----------------------------------------------------------------------
msg$ = "-i-USER NAME + CURRENT PASSWORD are valid" !
else ! MANAGER
msg$ = "-i-MANAGER + PASSWORD are valid and USER NAME exists" !
end if !
!
alt$ = "" ! init
dbg$ = "" ! init
status% = 0 ! init to success (1=warning, 2=error)
!-----------------------------------------------------------------------
! display bit details to programmer (output to dbg$)
!-----------------------------------------------------------------------
dbg$ = dbg$ +"<br>-i-UAI-Encryption Type: " !
select uai_encrytion_type% !
case UAI$C_AD_II !
dbg$ = dbg$ +"UAI$C_AD_II" !
case UAI$C_PURDY !
dbg$ = dbg$ +"UAI$C_PURDY" !
case UAI$C_PURDY_V !
dbg$ = dbg$ +"UAI$C_PURDY_V" !
case UAI$C_PURDY_S !
dbg$ = dbg$ +"UAI$C_PURDY_S" !
case else !
dbg$ = dbg$ +"<br>???" !
end select !
!
dbg$ = dbg$ +"<br>-i-UAI-Flags1: "+str$(uai_flags1%) !
!
if (uai_flags1% and UAI$M_PWDMIX) = 0 then !
dbg$ = dbg$ +"<br>-i-UAI$M_PWDMIX = 0" !
else !
dbg$ = dbg$ +"<br>-i-UAI$M_PWDMIX = 1" !
end if !
!
if (uai_flags1% and UAI$M_DISPWDHIS) = 0 then !
dbg$ = dbg$ +"<br>-i-UAI$M_DISPWDHIS = 0" !
else !
dbg$ = dbg$ +"<br>-i-UAI$M_DISPWDHIS = 1" !
end if !
!
if (uai_flags1% and UAI$M_DISPWDDIC) = 0 then !
dbg$ = dbg$ +"<br>-i-UAI$M_DISPWDDIC = 0" !
else !
dbg$ = dbg$ +"<br>-i-UAI$M_DISPWDDIC = 1" !
end if !
!
if (uai_flags1% and UAI$M_DISFORCE_PWD_CHANGE) = 0 then !
dbg$ = dbg$ +"<br>-i-UAI$M_DISFORCE_PWD_CHANGE = 0" !
else !
dbg$ = dbg$ +"<br>-i-UAI$M_DISFORCE_PWD_CHANGE = 1" !
end if !
!-----------------------------------------------------------------------
! now test flags (output to alt$)
!-----------------------------------------------------------------------
if (uai_flags1% and UAI$M_DISACNT) <> 0 then !
alt$ = alt$ +"<br>"+ "-e-account disabled" !
status% = 2 ! error
end if !
!
if (uai_flags1% and UAI$M_GENPWD) <> 0 then !
alt$ = alt$ +"<br>"+ "-e-user is requires to use generated passwords"
status% = 2 ! error
end if !
!
if (uai_flags1% and UAI$M_LOCKPWD) <> 0 then !
alt$ = alt$ +"<br>"+ "-e-the password is locked (can't be changed)" !
status% = 2 ! error
end if !
!
if (uai_flags1% and UAI$M_LOCKPWD) <> 0 then !
alt$ = alt$ +"<br>"+ "-e-the password is locked (can't be changed)" !
status% = 2 ! error
end if !
!
if (uai_flags1% and UAI$M_LOCKPWD) <> 0 then !
alt$ = alt$ +"<br>"+ "-w-the password is expired" !
status% = 1 ! warning
end if !
!
select status% !
case 0 ! ok
case 1 ! warning
case else ! error
goto send_response ! exit now
end select !
!
%let %dvlpexit = 0 ! disabled for now
%if %dvlpexit = 1 %then !
goto send_response ! PROGRAMMER early exit
%end %if !
!-----------------------------------------------------------------------
! keep going (prep to change)
!-----------------------------------------------------------------------
if pass1$ = pass2$ then !
msg$ = "-e-Error, CURRENT PASSWORD = NEW PASSWORD" !
goto send_response !
end if !
if len(pass2$) < uai_min_pwd_length% then !
msg$ = "-e-Error, NEW PASSWORD is smaller than "+ str$(uai_min_pwd_length%) +" characters (from SYSUAF)"
goto send_response !
end if !
if len(pass2$) > UAI$C_MAX_PWD_LENGTH then !
msg$ = "-e-Error, NEW PASSWORD is larger than "+ str$(UAI$C_MAX_PWD_LENGTH) +" characters (from STARLET)"
goto send_response !
end if !
if pass2$ <> pass3$ then !
msg$ = "-e-Error, NEW PASSWORD <> VERIFY PASSWORD" !
goto send_response !
end if !
!-----------------------------------------------------------------------
! OPTIONAL
! modify some flags (may need to do this BEFORE we change the password)
!-----------------------------------------------------------------------
uai_flags2% = uai_flags1% ! copy flags for COS tests
!
if (uai_flags2% and UAI$M_DISPWDHIS) = 0 then ! if clear
uai_flags2% = uai_flags2% or UAI$M_DISPWDHIS ! then set
end if !
if (uai_flags2% and UAI$M_DISPWDDIC) = 0 then ! if clear
uai_flags2% = uai_flags2% or UAI$M_DISPWDDIC ! then set
end if !
if (uai_flags2% and UAI$M_GENPWD) <> 0 then ! if set
uai_flags2% = uai_flags2% and (-1% - UAI$M_GENPWD) ! then clear
end if !
dbg$ = dbg$ +"<br>-i-UAI-Flags2: "+str$(uai_flags2%) !
!
if uai_flags1% = uai_flags2% then ! if flags are the same...
dbg$ = dbg$ +" (same as Flags1)" !
goto skip_flags_modify ! JUMP
else ! else...
dbg$ = dbg$ +" (different than Flags1)" !
end if !
!
! prep for first call to $setuai
!
myItems(0)::BuffLen = 4 ! size of uai_flags2 in bytes (UAI$S_FLAGS)
myItems(0)::ItemCode = UAI$_FLAGS !
myItems(0)::BuffAddr = loc(uai_flags2%) ! addr of uai_flags2
myItems(0)::RtnLenAdr = 0 ! location of bytes returned (don't care)
!
myItems(1)::List_Terminator = 0 !
!
! SYS$SETUAI [nullarg] ,[contxt] ,usrnam ,itmlst ,[nullarg] ,[nullarg] ,[nullarg]
!
rc% = sys$setuai(,,user1$,myItems(0),,,) !
rc_bits% = (rc% and 7%) !
if rc_bits% <> 1% then !
select rc% !
case RMS$_RSZ !
msg$ = "-e-Error, The UAF record is smaller than required; the SYSUAF is likely corrupt."
case SS$_NOGRPPRV !
msg$ = "-e-Error, Insufficient GROUP privs (for Apache)" !
case SS$_NOSYSPRV !
msg$ = "-e-Error, Insufficient SYSTEM privs (for Apache)" !
case else !
msg$ = "-e-setuai-"+ mid$(k_error_severity$, rc_bits%+1, 1) +"-rc: "+str$(rc%)
end select !
goto send_response !
end if !
skip_flags_modify: !
!-----------------------------------------------------------------------
! prep to change the password
! note: by leaving quad_time initialized, PWD LIFETIME will be cleared
!-----------------------------------------------------------------------
!
! prep for call to sys$getuai (fetch hashed password of desired user)
!
map(pass2)string new_password = 32 !
new_password = pass2$ ! xfer descriptor to fixed
!
myItems(0)::BuffLen = len(pass2$) ! size of actual data
myItems(0)::ItemCode = UAI$_PASSWORD !
myItems(0)::BuffAddr = loc(new_password) ! addr of new password
myItems(0)::RtnLenAdr = 0 ! location of bytes returned (don't care)
!
myItems(1)::BuffLen = 8 ! size of actual data
myItems(1)::ItemCode = UAI$_PWD_LIFETIME !
myItems(1)::BuffAddr = loc(quad_time) ! addr of new password
myItems(1)::RtnLenAdr = 0 ! location of bytes returned (don't care)
!
myItems(2)::List_Terminator = 0 !
!
! SYS$SETUAI [nullarg] ,[contxt] ,usrnam ,itmlst ,[nullarg] ,[nullarg] ,[nullarg]
!
rc% = sys$setuai(,,user1$,myItems(0),,,) !
rc_bits% = (rc% and 7%) !
if rc_bits% <> 1% then !
select rc% !
case RMS$_RSZ !
msg$ = "-e-Error, The UAF record is smaller than required; the SYSUAF is likely corrupt."
case SS$_NOGRPPRV !
msg$ = "-e-Error, Insufficient GROUP privs (for Apache)" !
case SS$_NOSYSPRV !
msg$ = "-e-Error, Insufficient SYSTEM privs (for Apache)" !
!~~~ case 9092 x bf_105.3
!~~~ msg$ = "-e-Error, New password contains illegal character(s)" x bf_105.3
case else !
flags% = 15% ! set all four bits
junk% = lib$sys_getmsg(rc%,,msg$,flags%) ! get error text from VMS bf_105.4
if (junk% and 7%) <> 1% then !
msg$ = "setuai-"+ mid$(k_error_severity$, rc_bits%+1, 1) +"-rc: "+str$(rc%)
end if !
msg$ = "-e-Error, "+ msg$ !
end select !
goto send_response !
end if !
!
!-----------------------------------------------------------------------
! horray...
!-----------------------------------------------------------------------
msg$ = "-i-success. Password changed for user: "+ user1$ !
goto send_response !
!
!=======================================================================
! send a response to the browser
!=======================================================================
send_response:
!
! prep messages for exit
!
select user1$ !
case "CUSTODIAN","PAGER" ! if my development accounts
if (dbg$ <> "") and (dvlp% = 1) then ! if any debug messages...
msg$ = msg$ + dbg$ ! ...then let's see them
end if !
end select !
!
if alt$ <> "" then ! if any alternative messages
msg$ = msg$ + alt$ ! then let's see them
end if !
!
out$ = 'Status: 200' +cr+lf+ ! good response &
'Cache-Control: no-cache, no-store' +cr+lf+ ! better than HTML meta &
'Content-type: text/html' +cr+lf+ ! &
'Content-disposition: inline; filename='+ dq + fake_fs2$ +dq +cr+lf ! &
+cr+lf+ ! end of mime BLOCK &
'<!DOCTYPE html>' +cr+lf+ ! &
'<html lang="en-us">' +cr+lf+ ! &
'<head>' +cr+lf+ ! &
'<title>ICSIS Password Change</title>' +cr+lf+ ! &
'<style type="text/css">' +cr+lf+ ! &
' body { font-family: Calibri, "Trebuchet MS", Verdana, sans-serif;' +cr+lf+ ! &
' font-size:12pt; background-color: #fff; }' +cr+lf+ ! &
' .title { color: red; font-size:14pt; font-weight:bold }' +cr+lf+ ! &
' .copy { color: black; font-size:13pt; font-weight:bold }' +cr+lf+ ! &
' a:link { color: blue }' +cr+lf+ ! &
' a:visited { color: blue }' +cr+lf+ ! &
' a:hover { color: blue; background-color: #ffa; cursor: pointer }' +cr+lf+ ! &
' a:active { color: blue }' +cr+lf+ ! &
' pre { font-weight:700 }' +cr+lf+ ! &
' form { font-family: "courier new" }' +cr+lf+ ! &
' .wb { background-color: #00f; color: #fff; font-weight: bold }' +cr+lf+ ! white-on-blue &
' .wr { background-color: #f00; color: #fff; font-weight: bold }' +cr+lf+ ! white-on-red &
' .y { background-color: #ff0; font-weight: bold }' +cr+lf+ ! yellow bold &
' .g { background-color: #9e9; font-weight: bold }' +cr+lf+ ! green bold &
' .b { color: blue }' +cr+lf+ ! blue &
' .r { color: red }' +cr+lf+ ! blue &
' .yellow { background-color: #ff0 }' +cr+lf+ ! yellow &
'</style>' +cr+lf+ ! &
'</head><body>' +cr+lf+ ! &
'<span class="title">ICSIS Password Change Tool</span>' + ! &
'<span class="copy"> Copyright © 2000-2013, Bell Canada</span>' + ! &
'<p>' + ! &
msg$ + ! &
'</p>' + ! &
'link: <a href="'+ script_uri$ +'">'+ url$ + "</a>" + ! &
'<p>' + ! &
'<img src="/images/valid-html401.gif" ' + ! &
'alt="Valid HTML 4.01 Transitional" style="border:0; width:88px">' + ! &
'</p></body></html>' !
print out$ ! bam...
!
%let %logactivity=2 ! 0=off, 1=sequential, 2=indexed
%if %logactivity=1 %then ! sequential event log
!
! output a simple one-liner data record
!
when error in !
open k_log_idx_fs$ as #108 ! &
,organization sequential ! &
,recordsize 32767 ! only limit the maximum record size &
,access append !
user4$ = "<blank>" if if user4$ = "" !
print #108, wcsm_dt_stamp +" manager: "+ user4$ +" user: "+ user1$ +" from ip: "+ remote_addr$ +" text: "+ msg$
use !
end when !
close #108 !
!
%end %if !
%if %logactivity=2 %then ! indexed event log
!
map(event109)string d109_whole_buffer = 155 , !&
d109_align = 0 !
map(event109)string d109_stamp = 14 , !&
d109_user = 20 , !&
d109_manager = 20 , !&
d109_remote_address = 20 , !&
d109_remote_port = 5 , !&
d109_server_address = 20 , !&
d109_server_port = 5 , !&
d109_flag = 1 , !&
d109_msg = 50 , !&
d109_align = 0 ! enforce alignment
when error in !
open k_log_idx_fs$ as #109 &
,organization indexed &
,map event109 &
,primary key d109_stamp
!
d109_whole_buffer = "" ! init buffer
d109_stamp = wcsm_dt_stamp !
d109_user = user1$ !
d109_manager = user4$ ! this might be blank
d109_remote_address = remote_addr$ !
d109_remote_port = remote_port$ !
d109_server_address = server_addr$ !
d109_server_port = server_port$ !
d109_msg = msg$ !
select edit$( mid$(junk$,1,3), 32) !
case "-E-" !
d109_flag = "e" !
case "-I-" !
d109_flag = "i" !
case else !
d109_flag = "?" !
end select !
put #109
use !
end when !
%end %if
!
!=======================================================================
! <<< that's all folks >>>
!=======================================================================
30000 fini:
close #99 ! release the lock
print "-i-exiting www_password_change_xxx.bas" if debug% > 0 !
end ! <<<------***
!########################################################################################################################
!
! <<< external functions >>>
!
32010 %include "[.fun]wcsm_trnlnm.fun"
! FUNCTION STRING WCSM_TRNLNM(LOGICAL_NAME, TABLE_NAME$)
!
32020 %include "[.fun]wcsm_dt_stamp.fun"
! FUNCTION STRING wcsm_dt_stamp
!
!========================================================================================================================
! <<< fix html data >>>
!========================================================================================================================
32030 function string fix_html_data(string html_input$) !
option type=explicit ! no kid stuff
declare long x%, y%, z%, handler_error%, &
string html$ !
!
html$ = html_input$ ! copy passed data string
!
! replace plus signs with spaces
!
strip_plus_sign: !
x% = pos(html$, "+", 1) ! locate "+"
if x% > 0% then ! if we found one...
mid$(html$, x%, 1) = " " ! replace with a space
goto strip_plus_sign ! look for more
end if !
!
! dehexify (eg. %0d -> chr$(13))
!
dehexify: !
declare string constant hex_string$ = "0123456789ABCDEF" !
x% = pos(html$, "%", 1) ! locate "%" (first time)
while x% <> 0 !
when error in !
y% = pos(hex_string$, mid$(html$, x%+1, 1) ,1) ! isolate char 1 and enumerate
z% = pos(hex_string$, mid$(html$, x%+2, 1), 1) ! isolate char 2 and enumerate
goto dehexify_exit if (y% = 0) or (z% = 0) ! danger Wil Robinson...
y% = (y% - 1) * 16 ! adjust tens digit
z% = (z% - 1) ! adjust ones digit
select (y% + z%) ! test the ASCII code
case < 32 ! control character?
%let %method = 2
%if %method = 1 %then !
html$ = seg$(html$, 1, x%-1) + seg$(html$, x%+3, len(html$)) ! then ignore all 3 chars
%else !
mid$(html$, x%, 1) = " " ! replace "%" with <space>
html$ = seg$(html$, 1, x% ) + seg$(html$, x%+3, len(html$)) ! and ignore the next two chars
x% = x% + 1 ! advance (incase we just decoded a percent)
%end %if !
case else ! not a control character
mid$(html$, x%, 1) = chr$(y% + z%) ! replace "%" with replacement character
html$ = seg$(html$, 1, x% ) + seg$(html$, x%+3, len(html$)) ! and ignore the next two chars
x% = x% + 1 ! advance (incase we just decoded a percent)
end select !
handler_error% = 0 ! cool
use !
handler_error% = err ! oops
end when !
goto dehexify_exit if handler_error% <> 0 !
x% = pos(html$,"%",x%) ! locate "%" (for next pass)
next !
html$ = edit$(html$, 128+16+8) ! no trail, compress to one, no lead
dehexify_exit: !
!
fix_html_data = html$ !
end function !
!