diff options
| author | Mitch Bradley <wmb@firmworks.com> | 2016-09-23 09:22:46 -1000 |
|---|---|---|
| committer | Mitch Bradley <wmb@firmworks.com> | 2016-09-28 07:05:08 -1000 |
| commit | cefecf58bacd72f4ee7993023348cdc495383f7c (patch) | |
| tree | a88dc03613f65cfa6bea1e5c75ab81497678725a | |
| parent | d081b4dcadee425e8f84989e8ffecfdb4b581c81 (diff) | |
| download | cforth-cefecf58bacd72f4ee7993023348cdc495383f7c.tar.gz | |
Added OFW configuration variables
31 files changed, 6722 insertions, 11 deletions
diff --git a/src/app/esp8266/app.fth b/src/app/esp8266/app.fth index 7df7ffd..c3034ea 100644 --- a/src/app/esp8266/app.fth +++ b/src/app/esp8266/app.fth @@ -134,6 +134,7 @@ fl ${BP}/ofw/parses1.fth fl ${BP}/ofw/cirstack.fth fl ${BP}/ofw/ofw-dt.fth fl ${BP}/ofw/core/deblock.fth +fl ${BP}/ofw/seechain.fth fl ${BP}/lib/fb.fth fl ${BP}/lib/font5x7.fth @@ -152,6 +153,20 @@ fl ../../lib/lex.fth fl ${BP}/ofw/disklabel/gpttools.fth fl ofw-rootnode.fth +fl ${BP}/ofw/filenv.fth + +: install-options ( -- ) + " /file-nvram" open-dev to nvram-node + nvram-node 0= if + ." The configuration EEPROM is not working" cr + then + config-valid? if exit then + ['] init-config-vars catch drop +; +stand-init: Pseudo-NVRAM + install-options +; + fl sdspi.fth @@ -166,4 +181,5 @@ fl sdspi.fth ['] spi-bits@ to spi-bits-in sd-card-init ; + " app.dic" save diff --git a/src/app/esp8266/ofw-rootnode.fth b/src/app/esp8266/ofw-rootnode.fth index 4900734..feb03a4 100644 --- a/src/app/esp8266/ofw-rootnode.fth +++ b/src/app/esp8266/ofw-rootnode.fth @@ -4,7 +4,10 @@ $200 constant pagesize : ram-range ( -- start end ) $3ffe8000 dup $14000 + ; \ All of RAM fload ${BP}/ofw/core/memops.fth \ Call memory node methods -\ fload ${BP}/ofw/confvar/loadcv.fth \ Configuration option management + +create no-tools +fload ${BP}/ofw/confvar/loadcv.fth \ Configuration option management + alias rb@ c@ alias rb! c! alias rw@ w@ diff --git a/src/ofw/confvar/#nameval.fth# b/src/ofw/confvar/#nameval.fth# new file mode 100644 index 0000000..eb90f2b --- /dev/null +++ b/src/ofw/confvar/#nameval.fth# @@ -0,0 +1,425 @@ +\ See license at end of file +purpose: "name=value" configuration variable encoding + +\ Configuration variables are stored in the configuration area in +\ name=value\0 form. Variables that are at their default values +\ are not stored, conserving NVRAM space (the default value is +\ stored in the dictionary entry). + +headerless + +\ This will be set later if the configuration variable area can be extended +defer cv-area ( -- adr len ) + +\ Generic version that uses all of available NVRAM +: (cv-area) ( -- adr len ) config-mem config-size ; +' (cv-area) to cv-area + +defer grow-cv-area ( needed -- ) ' drop to grow-cv-area + +\ Generic version that just looks for an obviously broken initial name +: (config-checksum?) ( -- flag ) + cv-area drop d# 32 bounds ?do ( ) + \ Good if we encounter '=' or \0 or ff before an unprintable character + i c@ dup 0= over [char] = = or swap h# ff = or if unloop true exit then + \ Bad if we encounter an unprintable character before the first = or \0 or ff + i c@ bl 1+ h# 7f within 0= if unloop false exit then + loop + \ Bad if the first name is too long + false +; +' (config-checksum?) to config-checksum? + + +: update-modified-adr ( adr -- ) config-mem - update-modified-range drop ; + +: another-ge-var? ( adr len -- false | adr' len' value$ name$ true ) + dup 0= if 2drop false exit then ( adr len ) + over c@ h# ff = if 2drop false exit then ( adr len ) + 0 left-parse-string ( adr' len' var$ ) + dup 0= if 4drop false exit then ( adr' len' var$ ) + [char] = left-parse-string ( adr' len' value$ name$ ) + true +; +: find-ge-var ( name$ -- true | rem$ value$ buf-name$ false ) + 2>r + cv-area + begin another-ge-var? while ( rem$ value$ name$ ) + 2dup 2r@ $= if 2r> 2drop false exit then ( rem$ value$ name$ ) + 4drop ( rem$ ) + repeat ( rem$ ) + 2r> 2drop true +; + +: env-end ( -- adr ) cv-area + ; +: env-cleared ( -- adr ) + cv-area dup 0= if + exit then ( adr len ) + + 0 -rot bounds 1+ swap do ( top-adr ) + drop i ( top-adr' ) + i 1- c@ if leave then ( top-adr' ) + -1 +loop ( top-adr' ) +; +: delete-ge-var ( rem$ value$ buf-name$ -- ) + drop nip nip nip ( rem-adr name-adr ) + + \ Set the low-water-mark + dup update-modified-adr ( rem-adr name-adr ) + + \ Find the top of the active NVRAM area + over env-cleared umax ( rem-adr name-adr top-adr ) + \ Set the high-water-mark + dup update-modified-adr ( rem-adr name-adr top-adr ) + + \ Copy the high portion down (from rem to name size [top-rem] + 3dup 2 pick - move ( rem-adr name-adr top-adr ) + + \ Clear the new piece at the top (from name+(top-rem) to top) + 2 pick - over + ( rem-adr name-adr name+top-rem ) + -rot - ( name+top-rem rem-name ) + h# ff fill +; +: ?delete-ge-var ( $name -- ) + find-ge-var 0= if delete-ge-var then +; +: find-available ( -- adr len ) + cv-area begin ( rem$ ) + dup if ( rem$ ) + over c@ h# ff = if ( rem$ ) + exit + then ( rem$ ) + then ( rem$ ) + 0 left-parse-string ( rem$ env$ ) + while drop repeat ( rem$ adr ) + -rot + over - ( adr len ) +; +: (cv-unused) ( -- len ) find-available nip ; +' (cv-unused) to cv-unused + +: get-available ( size -- adr fail? ) + >r find-available r@ - dup 0< if ( adr -need ) + nip negate grow-cv-area ( ) + find-available r@ u< ( adr fail? ) + else ( adr -need ) + drop false + then + r> drop +; +: add-ge-var ( $value $name -- value-len | -1 ) + 2 pick over + 2+ ( $value $name #bytes-needed ) + get-available if ( $value $name nv-name-adr ) + 5drop -1 ( -1 ) + else ( $value $name nv-name-adr ) + dup update-modified-adr ( $value $name nv-name-adr ) + >r ( $value $name ) + tuck r@ swap move ( $value name-len ) + r> + [char] = over c! 1+ ( $value nv-value-adr ) + 2dup 2>r swap move 2r> ( value-len nv-value-adr ) + over + 0 over c! ( value-len terminator-adr ) + update-modified-adr ( value-len ) + then ( value-len | -1 ) +; +: show-ge-area ( -- ) + cv-area ( rem$ ) + begin another-ge-var? while ( rem$ value$ name$ ) + exit? if 4drop 2drop exit then ( rem$ value$ name$ ) + 2dup $find-option if ( rem$ value$ name$ xt ) + 5drop ( rem$ ) + else ( rem$ value$ name$ ) + type value-column (type-entry) cr ( rem$ ) + then ( rem$ ) + repeat ( ) +; +' show-ge-area to show-extra-env-vars \ Install in user interface + +: show-ge-var ( $name -- ) + 2dup find-ge-var if ( $name ) + else ( name$ rem$ value$ buf-name$ ) + type value-column (type-entry) cr 4drop + then +; +' show-ge-var to show-extra-env-var \ Install in user interface + +: clear-ge-vars ( -- ) + cv-area h# ff fill + \ The 1- is necessary because update-modified-adr refers to + \ a byte that is touched, not the one just after it. + cv-area bounds update-modified-adr 1- update-modified-adr +; +' clear-ge-vars to erase-user-env-vars + +: (put-ge-var) ( value$ name$ -- len ) + config-rw 2dup ?delete-ge-var add-ge-var config-ro + cv-update +; +' (put-ge-var) to put-env-var \ Install in client interface + +: put-ge-var ( value$ name$ -- ) + (put-ge-var) -1 = if ." Out of NVRAM environment space" cr then +; +' put-ge-var to put-extra-env-var \ Install in user interface + +: ($unsetenv) ( name$ -- ) + config-rw ?delete-ge-var config-ro cv-update +; +' ($unsetenv) to $unsetenv + +: next-ge-var ( name$ -- name$' ) + dup if ( name$ ) + find-ge-var if ( ) + \ name$ does not refer to an extant user environment variable + null$ exit + else ( rem$ value$ name$ ) + \ name$ refers to an extant user environment variable; begin + \ the search after it + 4drop ( rem$ ) + then ( rem$ ) + else ( name$ ) + \ name$ is + null; start searching at the beginning of the GE area + 2drop cv-area ( rem$ ) + then ( rem$ ) + + \ In the remainder of the GE area, search for a environment variable + \ that is not one of the firmware-defined ones. + + begin another-ge-var? while ( rem$ value$ name$ ) + 2dup $find-option if ( rem$ value$ name$ xt ) + 5drop ( rem$ ) + else ( rem$ value$ name$ ) + 2swap 2drop 2swap 2drop ( name$ ) + exit + then ( rem$ ) + repeat ( ) + null$ +; +' next-ge-var to next-env-var \ Install in client interface + +: get-ge-var ( $name -- true | value$ false ) + find-ge-var if true exit then ( rem$ value$ name$ ) + 2drop 2swap 2drop false +; +' get-ge-var to get-env-var \ Install in client interface + +headers +: clear-nvram ( -- ) + config-rw + 0 update-modified-range drop config-size update-modified-range drop + config-mem config-size h# ff fill + set-mfg-defaults + config-ro + init-modified-range + cv-update +; +' clear-nvram is reset-config + +headerless +: read-ge-area ( -- ) + cv-area ( rem$ ) + begin another-ge-var? while ( rem$ value$ name$ ) + $find-option if ( rem$ value$ xt ) + nip >body 'cv-adr ! ( rem$ ) + else ( rem$ value$ ) + 2drop ( rem$ ) + then ( rem$ ) + repeat ( ) +; +stand-init: + ['] read-ge-area to cv-update +; + +: put-env$ ( val$ apf default-value? -- ) + config-rw + + \ Invalidate the old value pointer. It might seem that this should + \ be done inside the "default-value" branch of the test below, but + \ that would not work in the case where the attempt to add the new + \ value failed due to lack of space. + over 0 swap 'cv-adr ! ( val$ apf ) + + over body> >name name>string 2>r ( val$ apf default? ) ( r: name$ ) + + if ( val$ apf ) ( r: name$ ) + \ If the value to set is the same as the default value, + \ we just delete the old value if there is one. + 3drop 2r> $unsetenv ( ) + else ( val$ apf ) ( r: name$ ) + \ Otherwise we delete the old value if there is one, + \ and add the new value. + drop 2r> put-ge-var ( ) + then ( ) + + config-ro +; + +: init-options ( -- ) + ['] options follow + begin another? while + name> >body dup cv? if 0 swap 'cv-adr ! else drop then + repeat + read-ge-area +; + +: >cv$ ( cv-adr -- cv-adr cv-len ) + dup begin ( cv-adr adr ) + dup c@ dup 0<> swap h# ff <> and ( cv-adr adr more? ) + while ( cv-adr adr ) + 1+ ( cv-adr adr' ) + repeat ( cv-adr adr ) + over - ( cv-adr cv-len ) +; + +: (cv-flag@) ( apf -- flag ) cv-adr if >cv$ $>flag else @ 0<> then ; +: (cv-flag!) ( flag apf -- ) 2dup default-value? 2>r flag>$ 2r> put-env$ ; + +: (cv-int@) ( apf -- n ) cv-adr if >cv$ $>number else @ then ; +: (cv-int!) ( n apf -- ) 2dup default-value? 2>r (.d) 2r> put-env$ ; + +\ It uses three forms for the data: values in binary, strings in ASCII, +\ and a packed binary form in NVRAM. The packed form eliminates nulls and +\ FFs in the array by using FE as an escape: the next character represents +\ 1..3F nulls (if msbs are 00) or FEs (if msbs are 01) or FF (if msbs are 10). + +h# ffe constant /pack-buf +/pack-buf 2+ buffer: pack-buf +0 value pntr +: #consecutive ( lastadr adr b -- n ) + -rot ( b lastadr adr ) + tuck - h# 3f min ( b adr maxn ) + -rot 2 pick 0 do ( maxn b adr ) + 2dup i ca+ c@ <> if ( maxn b adr ) + 3drop i unloop exit ( n ) + then ( maxn b adr ) + loop ( maxn b adr ) + 2drop ( maxn ) +; +: pack-byte ( b -- full? ) + pack-buf pntr ca+ c! + pntr 1+ to pntr + /pack-buf pntr u<= +; +: pack-env ( adr len -- adr' len' ) \ Binary to packed + 0 to pntr bounds ?do ( ) + i c@ case ( c: char ) + 0 of ( ) + h# fe pack-byte ?leave ( ) + ilimit i 0 #consecutive ( step ) + dup ( step code ) + endof ( step code ) + h# fe of ( ) + h# fe pack-byte ?leave ( ) + ilimit i h# fe #consecutive ( step ) + dup h# 40 or ( step code ) + endof ( step code ) + h# ff of ( ) + h# fe pack-byte ?leave ( ) + ilimit i h# ff #consecutive ( step ) + dup h# 80 or ( step code ) + endof ( step code ) + ( default ) 1 swap dup ( step char char ) + endcase ( step code|char ) + pack-byte ?leave ( step ) + +loop ( ) + pack-buf pntr ( adr len ) +; +0 value unpack-buf +0 value /unpack-buf +: not-packed? ( adr len -- flag ) + dup false ( adr len len packed? ) + 2swap bounds ?do ( ulen packed? ) + i c@ h# fe = if ( ulen packed? ) + drop 2- \ fe and next ( ulen' ) + i 1+ c@ h# 3f and + \ #inserted ( ulen' ) + true 2 ( ulen packed? advance ) + else ( ulen packed? ) + 1 ( ulen packed? advance ) + then ( ulen advance ) + +loop ( ulen packed? ) + if ( ulen ) + dup to /unpack-buf ( ulen ) + alloc-mem to unpack-buf ( ) + false ( false ) + else ( ulen ) + drop true ( true ) + then ( flag ) +; + +: unpack-env ( adr len -- adr' len' ) \ Packed to binary + 2dup not-packed? if exit then ( adr len ) + 0 to pntr bounds ?do ( ) + /unpack-buf pntr u<= ?leave + 1 i c@ dup h# fe = if ( 1 c ) + 2drop 2 i 1+ c@ ( 2 n' ) + dup h# 3f and >r ( 2 n' ) + + 6 rshift ( 2 index ) + " "(00 fe ff ff)" drop + c@ ( 2 c' ) + + unpack-buf pntr ca+ ( 2 c' a ) + r@ /unpack-buf pntr - min ( 2 c' a len ) + rot fill ( 2 ) + r> pntr + to pntr ( 2 ) + else ( 1 c ) + unpack-buf pntr ca+ c! ( 1 ) + pntr 1+ to pntr ( 1 ) + then ( step ) + +loop ( ) + unpack-buf pntr ( adr len ) +; + +: (cv-bytes@) ( apf -- adr len ) + cv-adr if ( nvram-adr ) + >cv$ unpack-env ( adr len ) + else ( dictionary-adr ) + dup @ swap la1+ taligned swap ( adr len ) + then +; +: (cv-bytes!) ( adr len apf -- ) + 3dup $default-value? if ( adr len ) + true put-env$ ( ) + else ( adr len apf ) + >r ( adr len ) + pack-env ( adr' len' ) + r> false put-env$ ( ) + then ( ) +; + +: (cv-string@) ( apf -- adr len ) cv-adr if >cv$ unpack-env else rel@ cscount then ; +: (cv-string!) ( adr len apf -- ) (cv-bytes!) ; + +' (cv-flag@) to cv-flag@ +' (cv-flag!) to cv-flag! +' (cv-int@) to cv-int@ +' (cv-int!) to cv-int! +' (cv-string@) to cv-string@ +' (cv-string!) to cv-string! +' (cv-bytes@) to cv-bytes@ +' (cv-bytes!) to cv-bytes! + +headers +: init-config-vars ( -- ) + init-nvram-buffer init-options init-security +; +\ LICENSE_BEGIN +\ Copyright (c) 2006 FirmWorks +\ +\ Permission is hereby granted, free of charge, to any person obtaining +\ a copy of this software and associated documentation files (the +\ "Software"), to deal in the Software without restriction, including +\ without limitation the rights to use, copy, modify, merge, publish, +\ distribute, sublicense, and/or sell copies of the Software, and to +\ permit persons to whom the Software is furnished to do so, subject to +\ the following conditions: +\ +\ The above copyright notice and this permission notice shall be +\ included in all copies or substantial portions of the Software. +\ +\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +\ +\ LICENSE_END diff --git a/src/ofw/confvar/conftype.fth b/src/ofw/confvar/conftype.fth new file mode 100644 index 0000000..818544e --- /dev/null +++ b/src/ofw/confvar/conftype.fth @@ -0,0 +1,349 @@ +\ See license at end of file +purpose: Configuration option data types and encoding + +\ Maintenance of configuration parameters in non-volatile storage. +\ The PR*P and CHRP bindings require specific storage formats in NVRAM. + +\ Configuration items are stored in the dictionary as follows: +\ header +\ acf - Points to "action" data structure. 1 token +\ (apf) offset - Byte offset of data in user area. +\ High bit set indicates a "no-default"-type item +\ For integer-valued and enumerated data types, the +\ user area location contains the data. For string and +\ byte array data types, two user area locations contain +\ the address and length of the data. +\ default - Holds default data (unless "no-default" type). For +\ integer-valued and enumerated data types, the default +\ value is stored here as one cell. For string and byte +\ array data types, the length is stored as a cell, followed +\ by the data bytes. + +\ config object actions: ( value format depends on type of object ) +\ 0 get ( acf -- value ) +\ 1 set ( value acf -- ) +\ 2 addr ( acf -- adr ) +\ 3 decode ( value acf -- adr len ) value to ASCII +\ 4 encode ( adr len acf -- true | value false ) ASCII to value +\ 5 get-default ( acf -- value ) + +headerless + +\ Interface to the low-level storage mechanism/format for config variables + +\ Called when the config variable cache, if any, needs to be updated +defer cv-update ( -- ) ' noop to cv-update + +defer cv-unused ( -- #bytes ) + +\ Read and write primitive configuration data types +defer cv-flag@ ( apf -- flag ) +defer cv-flag! ( flag apf -- ) +defer cv-int@ ( apf -- n ) +defer cv-int! ( n apf -- ) +defer cv-string@ ( apf -- adr len ) +defer cv-string! ( adr len apf -- ) +defer cv-bytes@ ( apf -- adr len ) +defer cv-bytes! ( adr len apf -- ) +defer cv-secmode@ ( apf -- n ) ' cv-int@ to cv-secmode@ +defer cv-secmode! ( n apf -- ) ' cv-int! to cv-secmode! +defer cv-password@ ( apf -- adr len ) ' cv-string@ to cv-password@ +defer cv-password! ( adr len apf -- ) ' cv-string! to cv-password! + + +: nodefault ( -- ) lastacf >body dup l@ h# 80000000 or swap l! ; +: (nodefault?) ( apf -- flag ) l@ h# 80000000 and 0<> ; +' (nodefault?) to nodefault? + +: $default-value? ( val$ apf -- default? ) + dup nodefault? if drop nip 0= else body> get-default $= then +; +: default-value? ( n apf -- default? ) + dup nodefault? if 2drop false else body> get-default = then +; + +\ bad-number already defined in finddev.fth +\ create bad-number ," Bad number syntax" + +: $>flag ( adr len -- flag ) -null " true" $= ; +: flag>$ ( flag -- adr len ) if " true"(00)" else " false"(00)" then ; + +: 'cv-adr ( apf -- adr ) l@ h# c0000000 invert and up@ + ; +: cv? ( apf -- flag ) l@ h# 40000000 and 0<> ; + +: cv-adr ( apf -- adr overridden? ) + dup 'cv-adr @ dup if nip true else drop la1+ false then +; + +: create-option ( "name" -- ) + headerless? dup >r if headers then + also options definitions create previous definitions + r> if headerless then +; +: config-create ( "name" -- ua-offset ) + create-option + 0 /n ualloc dup h# 4000.0000 or l, up@ + ! +; + +headers +6 actions +action: ( apf -- flag ) cv-flag@ ; +action: ( flag apf -- ) cv-flag! ; +action: ( apf -- adr ) cv-adr drop ; +action: ( flag apf -- adr len ) drop flag>$ ; +action: ( adr len apf -- flag ) drop $>flag ; +action: ( apf -- flag ) la1+ @ 0<> ; + +: config-flag ( "name" default-value -- ) config-create use-actions , ; + +false config-flag diag-switch? +' diag-switch? is (diagnostic-mode?) + +headerless +: (.d) ( n -- adr len ) + base @ >r decimal <# 0 hold u#s u#> r> base ! +; +: ?base ( adr len -- adr' len' ) + dup 2 > if ( adr len ) + over c@ ascii 0 = if ( adr len ) + over 1+ c@ ascii x = if ( adr len ) + hex 2 /string ( adr+2 len-2 ) + else ( adr len ) + octal 1 /string ( adr+1 len-1 ) + then ( adr' len' ) + then ( adr' len' ) + then ( adr' len' ) +; +: $>number ( adr len -- n ) + -null ( adr,len' ) + base @ >r decimal ( adr,len ) ( r: base ) + ?base -trailing -leading ( adr',len' ) ( r: base ) + $number r> base ! if ( ) + bad-number throw ( ) + then ( n ) +; + +headers +: set-config-int-default ( n xt -- ) >body na1+ unaligned-! ; + +6 actions +action: ( apf -- n ) cv-int@ ; +action: ( n apf -- ) cv-int! ; +action: ( apf -- adr ) cv-adr drop ; +action: ( n apf -- adr len ) drop (.d) ; +action: ( adr len apf -- n ) drop $>number ; +action: ( apf -- n ) na1+ @ ; + +: config-int ( "name" default-value -- ) config-create use-actions , ; +: nodefault-int ( "name" -- ) 0 config-int nodefault ; + +: ,cstr ( $ -- adr ) + here over 1+ taligned note-string allot ( $ new-adr ) + place-cstr ( adr ) +; + +: rel! ( adr1 adr2 -- ) tuck - swap unaligned-! ; +: rel@ ( adr2 -- adr1 ) dup unaligned-@ + ; + +6 actions +action: ( apf -- adr len ) cv-string@ ; +action: ( adr len apf -- ) cv-string! ; +action: ( apf -- adr ) cv-adr drop ; +action: ( adr len apf -- adr len ) drop $cstr cscount 1+ ; +action: ( adr len apf -- adr len ) drop -null ; +action: ( apf -- adr len ) la1+ rel@ cscount ; + +\ This implementation of config-string ignores maxlen, using data representations +\ that do not require specifying a maximum length. +: config-string ( "name" default-value$ maxlen -- ) + config-create use-actions ( default-value$ maxlen ) + drop ( default-value$ ) + here >r /n allot ( default-value$ r: where ) \ Place location of def$ + ,cstr r> rel! ( ) +; +: nodefault-string ( "name" maxlen -- ) 0 0 swap config-string nodefault ; + +: set-config-string-default ( new-default$ xt -- ) + >body la1+ >r ( new-default$ r: ptr-adr ) + ,cstr r> rel! ( ) +; + +6 actions +action: ( apf -- adr len ) cv-bytes@ ; +action: ( adr len apf -- ) cv-bytes! ; +action: ( apf -- adr ) cv-adr drop ; +action: ( adr len apf -- adr len ) drop ; +action: ( adr len apf -- adr len ) drop ; +action: ( apf -- adr len ) la1+ dup la1+ swap @ ; + +\ e.g. keymap +: config-bytes ( "name" default-value-adr len maxlen -- ) + config-create use-actions drop ( adr len ) + dup , + dup taligned here swap note-string allot ( adr len here ) + swap move +; + +\ e.g. oem-logo +\ : nodefault-bytes ( "name" maxlen -- ) 0 0 swap config-bytes nodefault ; +: nodefault-bytes ( "name" maxlen -- ) + 0 0 rot config-bytes + nodefault + cv-update +; + +\ Define a configuration variable for security with the following values: +\ 0 = "none" +\ 1 = "command" +\ 2 = "full" + +create invalid-value ," Invalid value for configuration parameter" + +6 actions \ the sixth action might not be needed, due to no default +action: ( apf -- n ) cv-secmode@ ; +action: ( n apf -- ) cv-secmode! ; +action: ( apf -- adr ) ; +action: ( n apf -- adr len ) + drop + case + 1 of " command"(00)" endof + 2 of " full"(00)" endof + " none"(00)" rot + endcase +; +action: ( adr len apf -- n ) + drop -null + 2dup " full" $= if 2drop 2 exit then + 2dup " command" $= if 2drop 1 exit then + " none" $= if 0 exit then + invalid-value throw +; +action: ( apf -- n ) drop 0 ; + +headers +config-create security-mode use-actions 0 , nodefault + +0 nodefault-int security-#badlogins + + +defer system$ ' null$ to system$ +: encode-pw ( password$ -- digest$ ) system$ $md5digest2 ; + +6 actions +action: ( apf -- adr len ) cv-password@ ; +action: ( adr len apf -- ) cv-password! ; +action: ( apf -- adr ) ; +action: ( adr len apf -- adr len ) 3drop 0 0 ; +action: ( adr len apf -- adr len ) drop encode-pw ; +action: ( apf -- adr len ) drop 0 0 ; + +config-create security-password use-actions 0 , nodefault + +headerless + +\ true if command or full security +: security-on? ( -- flag ) security-mode 1 2 between ; + +d# 14 constant max-password +max-password buffer: pwbuf0 +max-password buffer: pwbuf1 + +: legal-passwd-char? ( char -- flag ) bl h# 7e between ; +: get-password ( adr -- adr len ) + 0 begin ( adr len ) + key dup linefeed <> over carret <> and + while ( adr len char ) + 2dup legal-passwd-char? swap max-password < and if ( adr len char ) + >r 2dup + r> swap c! ( adr len ) + 1+ ( adr len ) + else ( adr len char ) + drop beep ( adr len ) + then ( adr len ) + repeat ( adr len char ) + drop cr +; + +: password-okay? ( -- good-pw? ) + security-on? 0= if true exit then + + ??cr ." Firmware Password: " + pwbuf0 get-password encode-pw ( digest$ ) + security-password compare 0= if true exit then ( ) + + ." Sorry. Waiting 10 seconds." cr + security-#badlogins 1+ to security-#badlogins + lock[ d# 10.000 ms ]unlock + false +; + +headers +: password ( -- ) + ." New password (" max-password .d ." characters max) " + pwbuf0 get-password ( adr len ) + ." Retype new password: " pwbuf1 get-password ( adr len adr len ) + + 2over $= if ( adr len ) + ['] security-password encode ( true | adr len false ) + if + ." Invalid string - password unchanged" cr + else + ['] security-password set ( ) + then + else + 2drop ( ) + ." Mismatch - password unchanged" cr + then +; + +headerless +: (?permitted) ( adr len -- adr len ) + source-id if exit then \ Apply security only to interaction + 2dup " go" $= if exit then + 2dup " boot" $= if exit then + password-okay? 0= abort" " +; +: secure ( -- ) + ['] (?permitted) is ?permitted + [ also hidden ] ['] security-on? is deny-history? [ previous ] +; +: unsecure ( -- ) + ['] noop is ?permitted + [ also hidden ] ['] false is deny-history? [ previous ] +; +: init-security ( -- ) + security-on? if secure else unsecure then +; +headers + + +[ifdef] v2-compat +" /openprom" find-device + \ Bug ID 1120271 NVRAM decode bug + \ Indicates the presence of the fix for the + \ 'decode' action of the NVRAM parameters + 0 0 " decode-complete" property +device-end +[then] +\ LICENSE_BEGIN +\ Copyright (c) 2006 FirmWorks +\ +\ Permission is hereby granted, free of charge, to any person obtaining +\ a copy of this software and associated documentation files (the +\ "Software"), to deal in the Software without restriction, including +\ without limitation the rights to use, copy, modify, merge, publish, +\ distribute, sublicense, and/or sell copies of the Software, and to +\ permit persons to whom the Software is furnished to do so, subject to +\ the following conditions: +\ +\ The above copyright notice and this permission notice shall be +\ included in all copies or substantial portions of the Software. +\ +\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +\ +\ LICENSE_END diff --git a/src/ofw/confvar/loadcv.fth b/src/ofw/confvar/loadcv.fth new file mode 100644 index 0000000..e8896bb --- /dev/null +++ b/src/ofw/confvar/loadcv.fth @@ -0,0 +1,34 @@ +\ See license at end of file +purpose: Load file for name=value configuration variable manager + +fload ${BP}/ofw/ppp/md5.fth +fload ${BP}/ofw/confvar/conftype.fth \ Configuration variable base types +fload ${BP}/ofw/confvar/nvramrcg.fth \ NVRAMRC (generic version) +[ifndef] no-tools +fload ${BP}/ofw/confvar/nvalias.fth \ Persistent devaliases +[then] +fload ${BP}/ofw/confvar/nvcache.fth \ NVRAM cache +fload ${BP}/ofw/confvar/nameval.fth \ name=value config variable encoding +\ LICENSE_BEGIN +\ Copyright (c) 2006 FirmWorks +\ +\ Permission is hereby granted, free of charge, to any person obtaining +\ a copy of this software and associated documentation files (the +\ "Software"), to deal in the Software without restriction, including +\ without limitation the rights to use, copy, modify, merge, publish, +\ distribute, sublicense, and/or sell copies of the Software, and to +\ permit persons to whom the Software is furnished to do so, subject to +\ the following conditions: +\ +\ The above copyright notice and this permission notice shall be +\ included in all copies or substantial portions of the Software. +\ +\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +\ +\ LICENSE_END diff --git a/src/ofw/confvar/nameval.fth b/src/ofw/confvar/nameval.fth new file mode 100644 index 0000000..7cde485 --- /dev/null +++ b/src/ofw/confvar/nameval.fth @@ -0,0 +1,424 @@ +\ See license at end of file +purpose: "name=value" configuration variable encoding + +\ Configuration variables are stored in the configuration area in +\ name=value\0 form. Variables that are at their default values +\ are not stored, conserving NVRAM space (the default value is +\ stored in the dictionary entry). + +headerless + +\ This will be set later if the configuration variable area can be extended +defer cv-area ( -- adr len ) + +\ Generic version that uses all of available NVRAM +: (cv-area) ( -- adr len ) config-mem config-size ; +' (cv-area) to cv-area + +defer grow-cv-area ( needed -- ) ' drop to grow-cv-area + +\ Generic version that just looks for an obviously broken initial name +: (config-checksum?) ( -- flag ) + cv-area drop d# 32 bounds ?do ( ) + \ Good if we encounter '=' or \0 or ff before an unprintable character + i c@ dup 0= over [char] = = or swap h# ff = or if unloop true exit then + \ Bad if we encounter an unprintable character before the first = or \0 or ff + i c@ bl 1+ h# 7f within 0= if unloop false exit then + loop + \ Bad if the first name is too long + false +; +' (config-checksum?) to config-checksum? + + +: update-modified-adr ( adr -- ) config-mem - update-modified-range drop ; + +: another-ge-var? ( adr len -- false | adr' len' value$ name$ true ) + dup 0= if 2drop false exit then ( adr len ) + over c@ h# ff = if 2drop false exit then ( adr len ) + 0 left-parse-string ( adr' len' var$ ) + dup 0= if 4drop false exit then ( adr' len' var$ ) + [char] = left-parse-string ( adr' len' value$ name$ ) + true +; +: find-ge-var ( name$ -- true | rem$ value$ buf-name$ false ) + 2>r + cv-area + begin another-ge-var? while ( rem$ value$ name$ ) + 2dup 2r@ $= if 2r> 2drop false exit then ( rem$ value$ name$ ) + 4drop ( rem$ ) + repeat ( rem$ ) + 2r> 2drop true +; + +: env-end ( -- adr ) cv-area + ; +: env-cleared ( -- adr ) + cv-area dup 0= if + exit then ( adr len ) + + 0 -rot bounds 1+ swap do ( top-adr ) + drop i ( top-adr' ) + i 1- c@ if leave then ( top-adr' ) + -1 +loop ( top-adr' ) +; +: delete-ge-var ( rem$ value$ buf-name$ -- ) + drop nip nip nip ( rem-adr name-adr ) + + \ Set the low-water-mark + dup update-modified-adr ( rem-adr name-adr ) + + \ Find the top of the active NVRAM area + over env-cleared umax ( rem-adr name-adr top-adr ) + \ Set the high-water-mark + dup update-modified-adr ( rem-adr name-adr top-adr ) + + \ Copy the high portion down (from rem to name size [top-rem] + 3dup 2 pick - move ( rem-adr name-adr top-adr ) + + \ Clear the new piece at the top (from name+(top-rem) to top) + 2 pick - over + ( rem-adr name-adr name+top-rem ) + -rot - ( name+top-rem rem-name ) + h# ff fill +; +: ?delete-ge-var ( $name -- ) + find-ge-var 0= if delete-ge-var then +; +: find-available ( -- adr len ) + cv-area begin ( rem$ ) + dup if ( rem$ ) + over c@ h# ff = if ( rem$ ) + exit + then ( rem$ ) + then ( rem$ ) + 0 left-parse-string ( rem$ env$ ) + while drop repeat ( rem$ adr ) + -rot + over - ( adr len ) +; +: (cv-unused) ( -- len ) find-available nip ; +' (cv-unused) to cv-unused + +: get-available ( size -- adr fail? ) + >r find-available r@ - dup 0< if ( adr -need ) + nip negate grow-cv-area ( ) + find-available r@ u< ( adr fail? ) + else ( adr -need ) + drop false + then + r> drop +; +: add-ge-var ( $value $name -- value-len | -1 ) + 2 pick over + 2+ ( $value $name #bytes-needed ) + get-available if ( $value $name nv-name-adr ) + 5drop -1 ( -1 ) + else ( $value $name nv-name-adr ) + dup update-modified-adr ( $value $name nv-name-adr ) + >r ( $value $name ) + tuck r@ swap move ( $value name-len ) + r> + [char] = over c! 1+ ( $value nv-value-adr ) + 2dup 2>r swap move 2r> ( value-len nv-value-adr ) + over + 0 over c! ( value-len terminator-adr ) + update-modified-adr ( value-len ) + then ( value-len | -1 ) +; +: show-ge-area ( -- ) + cv-area ( rem$ ) + begin another-ge-var? while ( rem$ value$ name$ ) + exit? if 4drop 2drop exit then ( rem$ value$ name$ ) + 2dup $find-option if ( rem$ value$ name$ xt ) + 5drop ( rem$ ) + else ( rem$ value$ name$ ) + type value-column (type-entry) cr ( rem$ ) + then ( rem$ ) + repeat ( ) +; +' show-ge-area to show-extra-env-vars \ Install in user interface + +: show-ge-var ( $name -- ) + 2dup find-ge-var if ( $name ) + else ( name$ rem$ value$ buf-name$ ) + type value-column (type-entry) cr 4drop + then +; +' show-ge-var to show-extra-env-var \ Install in user interface + +: clear-ge-vars ( -- ) + cv-area h# ff fill + \ The 1- is necessary because update-modified-adr refers to + \ a byte that is touched, not the one just after it. + cv-area bounds update-modified-adr 1- update-modified-adr +; +' clear-ge-vars to erase-user-env-vars + +: (put-ge-var) ( value$ name$ -- len ) + config-rw 2dup ?delete-ge-var add-ge-var config-ro + cv-update +; +' (put-ge-var) to put-env-var \ Install in client interface + +: put-ge-var ( value$ name$ -- ) + (put-ge-var) -1 = if ." Out of NVRAM environment space" cr then +; +' put-ge-var to put-extra-env-var \ Install in user interface + +: ($unsetenv) ( name$ -- ) + config-rw ?delete-ge-var config-ro cv-update +; +' ($unsetenv) to $unsetenv + +: next-ge-var ( name$ -- name$' ) + dup if ( name$ ) + find-ge-var if ( ) + \ name$ does not refer to an extant user environment variable + null$ exit + else ( rem$ value$ name$ ) + \ name$ refers to an extant user environment variable; begin + \ the search after it + 4drop ( rem$ ) + then ( rem$ ) + else ( name$ ) + \ name$ is null; start searching at the beginning of the GE area + 2drop cv-area ( rem$ ) + then ( rem$ ) + + \ In the remainder of the GE area, search for a environment variable + \ that is not one of the firmware-defined ones. + + begin another-ge-var? while ( rem$ value$ name$ ) + 2dup $find-option if ( rem$ value$ name$ xt ) + 5drop ( rem$ ) + else ( rem$ value$ name$ ) + 2swap 2drop 2swap 2drop ( name$ ) + exit + then ( rem$ ) + repeat ( ) + null$ +; +' next-ge-var to next-env-var \ Install in client interface + +: get-ge-var ( $name -- true | value$ false ) + find-ge-var if true exit then ( rem$ value$ name$ ) + 2drop 2swap 2drop false +; +' get-ge-var to get-env-var \ Install in client interface + +headers +: clear-nvram ( -- ) + config-rw + 0 update-modified-range drop config-size update-modified-range drop + config-mem config-size h# ff fill + set-mfg-defaults + config-ro + init-modified-range + cv-update +; +' clear-nvram is reset-config + +headerless +: read-ge-area ( -- ) + cv-area ( rem$ ) + begin another-ge-var? while ( rem$ value$ name$ ) + $find-option if ( rem$ value$ xt ) + nip >body 'cv-adr ! ( rem$ ) + else ( rem$ value$ ) + 2drop ( rem$ ) + then ( rem$ ) + repeat ( ) +; +stand-init: + ['] read-ge-area to cv-update +; + +: put-env$ ( val$ apf default-value? -- ) + config-rw + + \ Invalidate the old value pointer. It might seem that this should + \ be done inside the "default-value" branch of the test below, but + \ that would not work in the case where the attempt to add the new + \ value failed due to lack of space. + over 0 swap 'cv-adr ! ( val$ apf ) + + over body> >name name>string 2>r ( val$ apf default? ) ( r: name$ ) + + if ( val$ apf ) ( r: name$ ) + \ If the value to set is the same as the default value, + \ we just delete the old value if there is one. + 3drop 2r> $unsetenv ( ) + else ( val$ apf ) ( r: name$ ) + \ Otherwise we delete the old value if there is one, + \ and add the new value. + drop 2r> put-ge-var ( ) + then ( ) + + config-ro +; + +: init-options ( -- ) + ['] options follow + begin another? while + name> >body dup cv? if 0 swap 'cv-adr ! else drop then + repeat + read-ge-area +; + +: >cv$ ( cv-adr -- cv-adr cv-len ) + dup begin ( cv-adr adr ) + dup c@ dup 0<> swap h# ff <> and ( cv-adr adr more? ) + while ( cv-adr adr ) + 1+ ( cv-adr adr' ) + repeat ( cv-adr adr ) + over - ( cv-adr cv-len ) +; + +: (cv-flag@) ( apf -- flag ) cv-adr if >cv$ $>flag else @ 0<> then ; +: (cv-flag!) ( flag apf -- ) 2dup default-value? 2>r flag>$ 2r> put-env$ ; + +: (cv-int@) ( apf -- n ) cv-adr if >cv$ $>number else @ then ; +: (cv-int!) ( n apf -- ) 2dup default-value? 2>r (.d) 2r> put-env$ ; + +\ It uses three forms for the data: values in binary, strings in ASCII, +\ and a packed binary form in NVRAM. The packed form eliminates nulls and +\ FFs in the array by using FE as an escape: the next character represents +\ 1..3F nulls (if msbs are 00) or FEs (if msbs are 01) or FF (if msbs are 10). + +h# ffe constant /pack-buf +/pack-buf 2+ buffer: pack-buf +0 value pntr +: #consecutive ( lastadr adr b -- n ) + -rot ( b lastadr adr ) + tuck - h# 3f min ( b adr maxn ) + -rot 2 pick 0 do ( maxn b adr ) + 2dup i ca+ c@ <> if ( maxn b adr ) + 3drop i unloop exit ( n ) + then ( maxn b adr ) + loop ( maxn b adr ) + 2drop ( maxn ) +; +: pack-byte ( b -- full? ) + pack-buf pntr ca+ c! + pntr 1+ to pntr + /pack-buf pntr u<= +; +: pack-env ( adr len -- adr' len' ) \ Binary to packed + 0 to pntr bounds ?do ( ) + i c@ case ( c: char ) + 0 of ( ) + h# fe pack-byte ?leave ( ) + ilimit i 0 #consecutive ( step ) + dup ( step code ) + endof ( step code ) + h# fe of ( ) + h# fe pack-byte ?leave ( ) + ilimit i h# fe #consecutive ( step ) + dup h# 40 or ( step code ) + endof ( step code ) + h# ff of ( ) + h# fe pack-byte ?leave ( ) + ilimit i h# ff #consecutive ( step ) + dup h# 80 or ( step code ) + endof ( step code ) + ( default ) 1 swap dup ( step char char ) + endcase ( step code|char ) + pack-byte ?leave ( step ) + +loop ( ) + pack-buf pntr ( adr len ) +; +0 value unpack-buf +0 value /unpack-buf +: not-packed? ( adr len -- flag ) + dup false ( adr len len packed? ) + 2swap bounds ?do ( ulen packed? ) + i c@ h# fe = if ( ulen packed? ) + drop 2- \ fe and next ( ulen' ) + i 1+ c@ h# 3f and + \ #inserted ( ulen' ) + true 2 ( ulen packed? advance ) + else ( ulen packed? ) + 1 ( ulen packed? advance ) + then ( ulen advance ) + +loop ( ulen packed? ) + if ( ulen ) + dup to /unpack-buf ( ulen ) + alloc-mem to unpack-buf ( ) + false ( false ) + else ( ulen ) + drop true ( true ) + then ( flag ) +; + +: unpack-env ( adr len -- adr' len' ) \ Packed to binary + 2dup not-packed? if exit then ( adr len ) + 0 to pntr bounds ?do ( ) + /unpack-buf pntr u<= ?leave + 1 i c@ dup h# fe = if ( 1 c ) + 2drop 2 i 1+ c@ ( 2 n' ) + dup h# 3f and >r ( 2 n' ) + + 6 rshift ( 2 index ) + " "(00 fe ff ff)" drop + c@ ( 2 c' ) + + unpack-buf pntr ca+ ( 2 c' a ) + r@ /unpack-buf pntr - min ( 2 c' a len ) + rot fill ( 2 ) + r> pntr + to pntr ( 2 ) + else ( 1 c ) + unpack-buf pntr ca+ c! ( 1 ) + pntr 1+ to pntr ( 1 ) + then ( step ) + +loop ( ) + unpack-buf pntr ( adr len ) +; + +: (cv-bytes@) ( apf -- adr len ) + cv-adr if ( nvram-adr ) + >cv$ unpack-env ( adr len ) + else ( dictionary-adr ) + dup @ swap la1+ taligned swap ( adr len ) + then +; +: (cv-bytes!) ( adr len apf -- ) + 3dup $default-value? if ( adr len ) + true put-env$ ( ) + else ( adr len apf ) + >r ( adr len ) + pack-env ( adr' len' ) + r> false put-env$ ( ) + then ( ) +; + +: (cv-string@) ( apf -- adr len ) cv-adr if >cv$ unpack-env else rel@ cscount then ; +: (cv-string!) ( adr len apf -- ) (cv-bytes!) ; + +' (cv-flag@) to cv-flag@ +' (cv-flag!) to cv-flag! +' (cv-int@) to cv-int@ +' (cv-int!) to cv-int! +' (cv-string@) to cv-string@ +' (cv-string!) to cv-string! +' (cv-bytes@) to cv-bytes@ +' (cv-bytes!) to cv-bytes! + +headers +: init-config-vars ( -- ) + init-nvram-buffer init-options init-security +; +\ LICENSE_BEGIN +\ Copyright (c) 2006 FirmWorks +\ +\ Permission is hereby granted, free of charge, to any person obtaining +\ a copy of this software and associated documentation files (the +\ "Software"), to deal in the Software without restriction, including +\ without limitation the rights to use, copy, modify, merge, publish, +\ distribute, sublicense, and/or sell copies of the Software, and to +\ permit persons to whom the Software is furnished to do so, subject to +\ the following conditions: +\ +\ The above copyright notice and this permission notice shall be +\ included in all copies or substantial portions of the Software. +\ +\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +\ +\ LICENSE_END diff --git a/src/ofw/confvar/nvalias.fth b/src/ofw/confvar/nvalias.fth new file mode 100644 index 0000000..cf8c339 --- /dev/null +++ b/src/ofw/confvar/nvalias.fth @@ -0,0 +1,194 @@ +\ ========== Copyright Header Begin ========================================== +\ +\ Hypervisor Software File: nvalias.fth +\ +\ Copyright (c) 2006 Sun Microsystems, Inc. All Rights Reserved. +\ +\ - Do no alter or remove copyright notices +\ +\ - Redistribution and use of this software in source and binary forms, with +\ or without modification, are permitted provided that the following +\ conditions are met: +\ +\ - Redistribution of source code must retain the above copyright notice, +\ this list of conditions and the following disclaimer. +\ +\ - Redistribution in binary form must reproduce the above copyright notice, +\ this list of conditions and the following disclaimer in the +\ documentation and/or other materials provided with the distribution. +\ +\ Neither the name of Sun Microsystems, Inc. or the names of contributors +\ may be used to endorse or promote products derived from this software +\ without specific prior written permission. +\ +\ This software is provided "AS IS," without a warranty of any kind. +\ ALL EXPRESS OR IMPLIED CONDITIONS, REPRESENTATIONS AND WARRANTIES, +\ INCLUDING ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS FOR A +\ PARTICULAR PURPOSE OR NON-INFRINGEMENT, ARE HEREBY EXCLUDED. SUN +\ MICROSYSTEMS, INC. ("SUN") AND ITS LICENSORS SHALL NOT BE LIABLE FOR +\ ANY DAMAGES SUFFERED BY LICENSEE AS A RESULT OF USING, MODIFYING OR +\ DISTRIBUTING THIS SOFTWARE OR ITS DERIVATIVES. IN NO EVENT WILL SUN +\ OR ITS LICENSORS BE LIABLE FOR ANY LOST REVENUE, PROFIT OR DATA, OR +\ FOR DIRECT, INDIRECT, SPECIAL, CONSEQUENTIAL, INCIDENTAL OR PUNITIVE +\ DAMAGES, HOWEVER CAUSED AND REGARDLESS OF THE THEORY OF LIABILITY, +\ ARISING OUT OF THE USE OF OR INABILITY TO USE THIS SOFTWARE, EVEN IF +\ SUN HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. +\ +\ You acknowledge that this software is not designed, licensed or +\ intended for use in the design, construction, operation or maintenance of +\ any nuclear facility. +\ +\ ========== Copyright Header End ============================================ +id: @(#)nvalias.fth 1.3 98/04/08 +purpose: Implements the nvalias persistent devalias feature +copyright: Copyright 1992-1998 Sun Microsystems, Inc. All Rights Reserved + +\ "Permanent" devaliases + +only forth also hidden also +hidden definitions +headerless + +: next-field ( str -- rem-str first-str ) -leading bl left-parse-string ; + +\ True if the current line contains a devalias command with the +\ same name as the one we're looking for. + +: this-alias? ( name-str -- name-str flag ) + after next-field ( name-str rem-str first-field-str ) + " devalias" $= if ( name-str rem-str ) + next-field ( name-str rem-str' 2nd-field-str ) + 5 pick 5 pick $= if ( name-str rem-str' ) + 2drop true exit ( name-str true ) + then ( name-str rem-str' ) + then ( name-str rem-str ) + 2drop false ( name-str false ) +; + +\ delete-old-alias leaves the cursor at the beginning of an empty line. +\ If there was already an alias of the indicated name, it is deleted +\ and the cursor is left on that line. Otherwise, a new line is +\ created at the end of the file, and the cursor is left on that line. + +: delete-old-alias ( name-str -- ) + buflen 0= if 2drop exit then + begin + this-alias? if ( name-str ) + 2drop ( ) + kill-to-end-of-line + kill-to-end-of-line exit + then ( name-str ) + last-line? 0= while ( name-str ) + next-line beginning-of-line ( name-str ) + repeat ( name-str ) + 2drop ( ) + beginning-of-file +; + +: safe-insert ( adr len -- ) + tuck (insert-characters) ( len actual ) + dup forward-characters ( len actual ) + <> if -1 throw then ( len ) +; +: make-new-alias ( name-str path-str -- ) + " devalias " safe-insert ( name-str path-str ) + 2swap safe-insert ( path-str ) + " " safe-insert ( path-str ) + safe-insert ( ) + split-line ( ) +; + +: get-field ( adr len -- rem-adr rem-len name-adr name-len ) + next-field dup 0= abort" Usage: nvalias name path" +; + +: edit-nvramrc ( -- ) + nvramrc-buffer if + ." 'nvalias' and 'nvunalias' cannot be executed while 'nvedit' is in progress." cr + ." Use 'nvstore' or 'nvquit' to finish editing nvramrc, then try again." cr + abort + then + + allocate-buffer + + [ also hidden ] + + nvbuf /nvramrc-max 0 0 false start-edit +; + +forth definitions +headers + +\ Creates a "devalias <name> <path>" command line in nvramrc, with name +\ and path fields given by the two strings on the stack. If nvramrc already +\ contains a devalias line with the same name, that entry is first deleted, +\ and the new entry replaces it at the same location in nvramrc. Otherwise, +\ the new entry is placed at the beginning of nvramrc. +\ +\ If there is insufficient space in nvramrc for the new devalias command, +\ a message to that effect is displayed and $nvalias aborts without +\ modifying nvramrc. +\ +\ If nvramrc was successfully modified, the new "devalias" command is +\ executed immediately, creating a new memory-resident alias. +\ +\ If nvramrc is currently being edited (i.e. nvedit has been executed, +\ but has not been completed with either nvstore or nvquit), $nvalias +\ aborts with an error message before taking any other action. + +: $nvalias ( name-str path-str -- ) + edit-nvramrc + + 2over delete-old-alias ( name-str path-str ) + 2over 2over ['] make-new-alias catch if ( ? ) + finish-edit drop + deallocate-buffer + true abort" Can't create new alias because nvramrc is full" + then ( name-str path-str ) + + $devalias ( ) + nvramrc-buffer finish-edit ( adr len ) to nvramrc + true to use-nvramrc? + + [ previous ] + deallocate-buffer +; + +\ nvalias is like $nvalias, except that the name and path arguments is taken +\ from the command line following the nvalias command, instead of from +\ the stack. + +: nvalias \ name path ( -- ) + optional-arg$ get-field ( rem-str name-str ) + 2swap get-field 2swap 2drop ( name-str path-str ) + $nvalias +; + +\ If nvramrc contains a "devalias" command line with the same name +\ as the string on the stack, $nvunalias deletes that line. Otherwise, +\ nvramrc remains unchanged. +\ +\ $nvunalias aborts with an error message if nvramrc is currently being edited, +\ i.e. nvedit has been executed, but has not been completed with either +\ nvstore or nvquit. + +: $nvunalias ( name-str -- ) + edit-nvramrc delete-old-alias + + [ also hidden ] + nvramrc-buffer finish-edit to nvramrc + [ previous ] + + deallocate-buffer +; + +\ nvunalias is like $nvalias, except that the name argument is taken +\ from the command line following the nvunalias command, instead of from +\ the stack. + +: nvunalias \ name ( -- ) + optional-arg$ get-field ( rem-str name-str ) + 2swap 2drop $nvunalias +; +only forth also definitions + diff --git a/src/ofw/confvar/nvcache.fth b/src/ofw/confvar/nvcache.fth new file mode 100644 index 0000000..e23139e --- /dev/null +++ b/src/ofw/confvar/nvcache.fth @@ -0,0 +1,140 @@ +\ See license at end of file +purpose: Write-through RAM cache for firmware NVRAM area + +\ A write-through copy of NVRAM is maintained in RAM. Only modified +\ areas are rewritten. Actual access is handled by the /nvram node. + +0 value nvram-node ' nvram-node " nvram" chosen-value + +headerless + +\ These can be set later to system-specific values +false value config-valid? +defer layout-config ' noop to layout-config +defer reset-config ' noop to reset-config +defer config-checksum? ' noop to config-checksum? + + +0 value config-size +0 value config-mem + +0 value min-modified +0 value max-modified + +: init-modified-range ( -- ) + 0 to max-modified config-size to min-modified +; +: modified-range ( -- min len ) min-modified max-modified 1+ over - 0 max ; + +: update-modified-range ( offset -- offset ) + dup min-modified min to min-modified + dup max-modified max to max-modified +; + +\ note: words are stored big-endian. +: nvram-c@ ( offset -- c ) config-mem + c@ ; +: nvram-w@ ( offset -- w ) dup ca1+ nvram-c@ swap nvram-c@ bwjoin ; +: nvram-l@ ( offset -- l ) dup wa1+ nvram-w@ swap nvram-w@ wljoin ; + +: nvram-c! ( c offset -- ) update-modified-range config-mem + c! ; +: nvram-w! ( w offset -- ) >r wbsplit r@ nvram-c! r> ca1+ nvram-c! ; +: nvram-l! ( l offset -- ) >r lwsplit r@ nvram-w! r> wa1+ nvram-w! ; + +: write-range ( min len -- ) + dup if ( min len ) + over 0 " seek" nvram-node $call-method drop ( min len ) + swap config-mem + swap " write" nvram-node $call-method drop + else + 2drop + then +; +: write-modified ( -- ) + modified-range write-range +; + +defer set-env-checksum ' noop to set-env-checksum +variable config-level +: (config-rw) ( -- ) 1 config-level +! ; +' (config-rw) to config-rw +: (config-ro) ( -- ) + -1 config-level +! + config-level @ 0= if + write-modified + set-env-checksum + init-modified-range + then +; +' (config-ro) to config-ro + +: read-nvram ( -- error? ) + init-modified-range + 0 0 " seek" nvram-node $call-method drop + config-mem config-size " read" nvram-node $call-method + config-size <> +; + +\ Call init-env-vars after opening the nvram node +: init-nvram-buffer ( -- ) + 0 config-level ! + + \ The "size" method returns a double number + " size" nvram-node $call-method drop to config-size + + config-size alloc-mem to config-mem + + read-nvram if + ." Can't read the configuration memory" cr + false + else + config-checksum? if + true + else + reset-config + read-nvram drop + config-checksum? if + true + else + ." Failed to set configuration memory to its default values" cr + false + then + then + then + to config-valid? + config-valid? 0= if + ." The configuration memory is invalid. Using default values." cr + then +; +headers +: set-mfg-defaults ( -- ) + config-rw + + layout-config + + set-defaults + + config-ro + config-checksum? to config-valid? +; +\ LICENSE_BEGIN +\ Copyright (c) 2006 FirmWorks +\ +\ Permission is hereby granted, free of charge, to any person obtaining +\ a copy of this software and associated documentation files (the +\ "Software"), to deal in the Software without restriction, including +\ without limitation the rights to use, copy, modify, merge, publish, +\ distribute, sublicense, and/or sell copies of the Software, and to +\ permit persons to whom the Software is furnished to do so, subject to +\ the following conditions: +\ +\ The above copyright notice and this permission notice shall be +\ included in all copies or substantial portions of the Software. +\ +\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +\ +\ LICENSE_END diff --git a/src/ofw/confvar/nvramrcg.fth b/src/ofw/confvar/nvramrcg.fth new file mode 100644 index 0000000..d007c35 --- /dev/null +++ b/src/ofw/confvar/nvramrcg.fth @@ -0,0 +1,103 @@ +\ See license at end of file +purpose: Implements the script and its editor + +headers + +" " 0 config-string nvramrc + +false config-flag use-nvramrc? + +headerless + +0 value nvramrc-buffer \ Buffer for editing nvramrc +0 value nvramrc-size \ Current size of file being edited in memory +: /nvramrc-max ( -- #bytes ) nvramrc nip cv-unused + ; + +: deallocate-buffer ( -- ) + nvramrc-buffer if + nvramrc-buffer /nvramrc-max free-mem + then + 0 is nvramrc-buffer + 0 is nvramrc-size +; +: allocate-buffer ( -- ) + nvramrc-buffer 0= if + /nvramrc-max alloc-mem is nvramrc-buffer + nvramrc-buffer /nvramrc-max erase + nvramrc is nvramrc-size ( adr ) + nvramrc-buffer nvramrc-size cmove ( cmove? ) + then +; + +headers +\ Returns address and length of edit buffer +: nvbuf ( -- adr len ) nvramrc-buffer nvramrc-size ; + +\ Allows you to recover the contents of the nvramrc file if its size +\ has been set to 0 by set-defaults. (NOT IMPLEMENTED) +: nvrecover ( -- ) true abort" Nothing to recover" ; + +\ Stop editing nvramrc, discarding the changes +: nvquit ( -- ) + ." Discard edits [y/n]? " + key dup emit cr upc ascii Y = if deallocate-buffer then +; + +\ Execute the contents of the nvramrc edit buffer +: nvrun ( -- ) nvbuf interpret-string ; + +\ Copy the contents of the nvramrce edit buffer back into the NVRAM, +\ and deallocate the edit buffer. +: nvstore ( -- ) + nvramrc-buffer if + nvbuf to nvramrc + deallocate-buffer + then +; + +\ Begin or continue editing nvramrc +: nvedit ( -- ) + allocate-buffer + [ also hidden ] + nvbuf /nvramrc-max edit-file is nvramrc-size + [ previous ] + + " Store script to NVRAM" confirmed? if + nvstore + use-nvramrc? 0= if + " Enable script" confirmed? if true to use-nvramrc? then + then + then +; + +headerless + +: execute-nvramrc ( -- ) + " nvramrc-" do-drop-in + use-nvramrc? if nvramrc interpret-string then + " nvramrc+" do-drop-in +; +headers +\ LICENSE_BEGIN +\ Copyright (c) 2006 FirmWorks +\ +\ Permission is hereby granted, free of charge, to any person obtaining +\ a copy of this software and associated documentation files (the +\ "Software"), to deal in the Software without restriction, including +\ without limitation the rights to use, copy, modify, merge, publish, +\ distribute, sublicense, and/or sell copies of the Software, and to +\ permit persons to whom the Software is furnished to do so, subject to +\ the following conditions: +\ +\ The above copyright notice and this permission notice shall be +\ included in all copies or substantial portions of the Software. +\ +\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +\ +\ LICENSE_END diff --git a/src/ofw/filenv.fth b/src/ofw/filenv.fth new file mode 100644 index 0000000..5875a1b --- /dev/null +++ b/src/ofw/filenv.fth @@ -0,0 +1,110 @@ +\ See license at end of file +purpose: File-based "NVRAM" driver package + +dev / +new-device + +" file-nvram" device-name + +h# 1000 value /nvram + +0 instance value nvram-fd +0 instance value nvram-ptr + +headerless + +: def-name ( -- filename$ ) " nvram.dat" ; +defer nv-file ' def-name to nv-file + +: nvopen ( -- okay? ) + nv-file r/w open-file 0= if ( fid ) + to nvram-fd true exit ( -- okay? ) + then ( fid ) + drop ( ) + + \ Try to make the file + nv-file r/w create-file if drop false exit then ( ) + nv-file r/w open-file if drop false exit then ( fid ) + to nvram-fd ( ) + /nvram allocate if drop false exit then ( adr ) + dup /nvram erase ( adr ) + dup /nvram nvram-fd write-file drop ( adr ) + free drop ( ) + 0. nvram-fd reposition-file 0= ( okay? ) +; +: update-ptr ( len' -- len' ) dup nvram-ptr + to nvram-ptr ; +: clip-size ( adr len -- adr len' ) \ data buffer + nvram-ptr + /nvram min nvram-ptr - ( adr len' ) +; + +headers + +: open ( -- okay? ) true ; +: close ( -- ) ; +: seek ( d.offset -- status ) + 0<> over /nvram u> or if + drop 0 to nvram-ptr true exit \ Seek offset too large + then + to nvram-ptr false +; +: read ( adr len -- actual ) + nvopen if + clip-size ( adr len ) + nvram-ptr u>d nvram-fd reposition-file drop ( adr len ) + nvram-fd read-file drop ( actual-len ) + nvram-fd close-file drop ( actual-len ) + update-ptr ( actual-len ) + else + 2drop 0 + then +; +: write ( adr len -- actual ) + nvopen if + clip-size ( adr len ) + nvram-ptr u>d nvram-fd reposition-file drop ( adr len ) + tuck nvram-fd write-file drop ( len ) + nvram-fd close-file drop ( len ) + update-ptr ( len ) + else + 2drop 0 + then +; +: size ( -- d ) /nvram 0 ; +: nvram@ ( offset -- n ) + 0 seek drop here 1 read if here c@ else 0 then +; +: nvram! ( n offset -- ) + 0 seek drop here c! here 1 write drop +; + +finish-device +device-end + +: nvr@ ( offset -- n ) " nvram@" nvram-node $call-method ; +: nvr! ( n offset -- ) " nvram!" nvram-node $call-method ; +' nvr@ to nv-c@ +' nvr! to nv-c! + +\ LICENSE_BEGIN +\ Copyright (c) 2006 FirmWorks +\ +\ Permission is hereby granted, free of charge, to any person obtaining +\ a copy of this software and associated documentation files (the +\ "Software"), to deal in the Software without restriction, including +\ without limitation the rights to use, copy, modify, merge, publish, +\ distribute, sublicense, and/or sell copies of the Software, and to +\ permit persons to whom the Software is furnished to do so, subject to +\ the following conditions: +\ +\ The above copyright notice and this permission notice shall be +\ included in all copies or substantial portions of the Software. +\ +\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +\ +\ LICENSE_END diff --git a/src/ofw/ofw-dt.fth b/src/ofw/ofw-dt.fth index 1774e71..c50b344 100644 --- a/src/ofw/ofw-dt.fth +++ b/src/ofw/ofw-dt.fth @@ -1,3 +1,17 @@ +: 5drop ( x x x x x -- ) 2drop 3drop ; + +: (confirmed?) ( adr len -- char ) + type ." [y/n]? " key dup emit cr upc +; +\ Default value is yes +: confirmed? ( adr len -- yes? ) (confirmed?) [char] N <> ; +\ Default value is no +: confirmedn? ( adr len -- yes? ) (confirmed?) [char] Y = ; + +defer edit-file ( adr maxlen -- actual-len ) : no-edit true abort" edit-file is not implemented" ; +defer ?permitted +defer deny-history? +: beep ( -- ) 7 emit ; : 8* ( n1 -- n2 ) 3 lshift ; : third ( a b c -- a b c a ) 2 pick ; : cstrlen ( adr -- len ) cscount drop ; @@ -78,7 +92,7 @@ alias do-is (to) ; \ XXX need to init "temp to stringbuf -alias config-flag value +\ alias config-flag value alias \tagvoc noop immediate alias \nottagvoc \ immediate @@ -90,9 +104,6 @@ alias end-module noop : nowarn( ( -- warning ) warning @ warning off ; : )nowarn ( warning -- ) warning ! ; -nowarn( -: stand-init ; -)nowarn : $save ( adr1 len1 adr2 -- adr2 len1 ) pack count ; : $cat ( adr len pstr -- ) \ Append adr len to the end of pstr >r r@ count + ( adr len end-adr ) ( r: pstr ) @@ -212,6 +223,7 @@ defer minimum-search-order alias unaligned-w! le-w! alias unaligned-l! le-l! +alias unaligned-! unaligned-l! 8 constant /x @@ -230,6 +242,7 @@ alias be-n, be-l, ; : strip-blanks ( adr len -- adr' len' ) -leading -trailing ; +: optional-arg$ ( -- adr len ) 0 parse strip-blanks ; \ : relink-voc ( voc -- ) drop ; \ CForth doesn't support transient so nothing to do @@ -294,9 +307,6 @@ alias include-buffer evaluate \ \ ========== Copyright Header End ============================================ -[ifdef] cforth -: stand-init: postpone \ " : stand-init " eval ; -[else] \ From standini.fth copyright: Copyright 2006 Sun Microsystems, Inc All Rights Reserved copyright: Use is subject to license terms. @@ -310,16 +320,22 @@ defer check-message ( adr len -- adr len ) ' noop to check-message ; only forth also hidden also forth definitions +[ifndef] cforth : stand-init-header ( -- ) headerless? 0= dup >r if headerless then - nowarn( + warning @ warning off " stand-init" $header acf-align - )nowarn + warning ! r> if headers then ; +[then] : stand-init: ( -- ) \ debug string +[ifdef] stand-init-header ['] stand-init-header is header : ['] (header) is header +[else] + nowarn( " : stand-init" evaluate )nowarn +[then] " stand-init" $find if token, else 2drop then optional-arg$ [ifdef] stand-init-debug? @@ -333,14 +349,20 @@ headerless \needs standalone? false value standalone? stand-init: First stand-init: hex +[ifndef] cforth 0 to #args 0 to args 0 to 'source-id true to suppress-transient? true to suppress-headerless? -; [then] +; only forth also definitions +[ifdef] cforth +\ CForth has standalone? as a primitive, not a value +: stand-init-io ( -- ) ; +[else] : stand-init-io ( -- ) true to standalone? ; \ First definition +[then] headers \ From sysintf.fth @@ -556,6 +578,9 @@ vocabulary options only forth also root also definitions : fw-search-order ( -- ) root also options also ; ' fw-search-order to minimum-search-order +warning @ warning off +: only only minimum-search-order ; +warning ! only forth hidden also forth also definitions \ end interpolation diff --git a/src/ofw/ppp/auth.fth b/src/ofw/ppp/auth.fth new file mode 100644 index 0000000..2733bc1 --- /dev/null +++ b/src/ofw/ppp/auth.fth @@ -0,0 +1,72 @@ +\ See license at end of file +purpose: PPP authentication and phase control + +\ Bits in auth_pending (used inline) +\ 1 constant UPAP_WITHPEER +\ 4 constant CHAP_WITHPEER + +0 value auth_pending \ Pending authentication operations +0 value auth_required \ Peer is required to authenticate + +: pap-id ( -- a n ) " pap-id" $ppp-info ; +: pap-password ( -- a n ) " pap-password" $ppp-info ; +: chap-name ( -- a n ) " chap-name" $ppp-info ; +: chap-secret ( -- a n ) " chap-secret" $ppp-info ; + +\ LCP has gone down; it will either die or try to re-establish. +: link_down ( -- ) + ipcp-fsm fsm_close + \ ccp_close + 4 to phase \ 4 is PHASE_TERMINATE +; + +\ Proceed to the network phase. +: network_phase ( -- ) + 3 to phase \ 3 is PHASE_NETWORK + ipcp-fsm fsm_open + \ ccp_open +; + +\ We have failed to authenticate ourselves to the peer using the given protocol. +: auth_withpeer_fail ( protocol -- ) + case + 4 of ." CHAP" endof + 1 of ." PAP" endof + ( default ) ." Unknown" + endcase + ." authentication failed" cr + link_down +; + +\ We have authenticated ourselves to the peer using the given protocol. +: auth_withpeer_success ( peer-code -- ) + invert auth_pending and + dup to auth_pending + \ If there is no more authentication still being done, + \ proceed to the network phase. + 0= if network_phase then +; + +\ LICENSE_BEGIN +\ Copyright (c) 2006 FirmWorks +\ +\ Permission is hereby granted, free of charge, to any person obtaining +\ a copy of this software and associated documentation files (the +\ "Software"), to deal in the Software without restriction, including +\ without limitation the rights to use, copy, modify, merge, publish, +\ distribute, sublicense, and/or sell copies of the Software, and to +\ permit persons to whom the Software is furnished to do so, subject to +\ the following conditions: +\ +\ The above copyright notice and this permission notice shall be +\ included in all copies or substantial portions of the Software. +\ +\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +\ +\ LICENSE_END diff --git a/src/ofw/ppp/chap.fth b/src/ofw/ppp/chap.fth new file mode 100644 index 0000000..b846f4d --- /dev/null +++ b/src/ofw/ppp/chap.fth @@ -0,0 +1,255 @@ +\ See license at end of file +purpose: CHAP -- PPP Cryptographic Handshake Authentication Protocol + +decimal + +5 constant CHAP_DIGEST_MD5 \ use MD5 algorithm + +\ CHAP codes. +1 constant CHAP_CHALLENGE +2 constant CHAP_RESPONSE +3 constant CHAP_SUCCESS +4 constant CHAP_FAILURE + +258 buffer: rhostname \ hostname received from remote system +258 buffer: rchallenge \ challenge received from remote system +258 buffer: chap-resp-name \ our name +258 buffer: secret \ our secret for remote system +16 buffer: chap-response \ digest calculated as response + +0 value chap-clientstate +0 value chap-resp-type \ hash algorithm for responses + +0 value chap-rto \ address of chap_responsetimeout + +variable chap-resp-transmits \ Number of transmissions of response +variable chap-resp-id + +: set-chap-state ( state -- ) + show-states? if ." chap " dup .state-name then + to chap-clientstate +; + +\ Authenticate us with our peer (start client). +: chap_authwithpeer ( our_name digest -- ) + to chap-resp-type + chap-resp-name place ( ) + + chap-clientstate PENDING = if exit then + + chap-clientstate INITIAL = if + \ lower layer isn't up - wait until later + PENDING set-chap-state + exit + then + + \ We get here as a result of LCP coming up. + \ So even if chap was open before, we will + \ have to re-authenticate ourselves. + LISTEN set-chap-state +; + +\ send a response packet +: chap_sendresponse ( -- ) + chap-resp-name c@ 21 + ( outlen ) + PPP_CHAP outpacket_buf makeheader ( outlen outp ) + CHAP_RESPONSE putc + chap-resp-id c@ putc + over putw ( outlen outp ) + 16 putc + chap-response 16 puts ( outlen outp ) + chap-resp-name count puts \ append our name + drop PPP_HDRLEN + outpacket_buf swap + ppp-write drop + + RESPONSE set-chap-state + chap-rto 0 3 timeout + 1 chap-resp-transmits +! +; + +\ Timeout expired on sending response. +: chap_responsetimeout ( arg -- ) + drop + chap-clientstate RESPONSE <> if exit then + + chap_sendresponse \ re-send the response +; + +\ Initialize a CHAP unit. +: chap_init ( -- ) + INITIAL set-chap-state + ['] chap_responsetimeout to chap-rto +; + +\ The lower layer is up. +\ Start up if we have pending requests. +: chap_lowerup ( -- ) + chap-clientstate case + INITIAL of CLOSED set-chap-state endof + PENDING of LISTEN set-chap-state endof + endcase +; + +\ The lower layer is down. +\ Cancel all timeouts. +: chap_lowerdown ( -- ) + chap-clientstate RESPONSE = if + ['] chap_responsetimeout 0 untimeout + then + INITIAL set-chap-state +; + +\ Peer doesn't grok CHAP. +: chap_protrej ( -- ) + chap-clientstate dup INITIAL <> swap CLOSED <> and if + 4 auth_withpeer_fail + then + chap_lowerdown \ shutdown CHAP +; + +\ open the CHAP secret file and return the secret +\ for authenticating the given client on the given server. +\ (We could be either client or server). +: get_secret ( server -- got? ) + \ 0 secret c! ( server ) + \ count " zinc.farmworks.com" $= 0= if + \ 2drop false exit + \ then ( ) + drop ( ) + + chap-secret secret place + true +; + +\ Receive Challenge and send Response. +: chap_receivechallenge ( a n id -- ) + chap-resp-id c! + + chap-clientstate dup CLOSED = swap PENDING = or if + 2drop exit + then ( a n ) + + dup 2 < if 2drop exit then ( a n ) + + swap getc ( n a rchal_len ) + 2dup rchallenge place ( n a rchal_len ) + rot swap /string 1- ( a n ) + dup 0< if 2drop exit then ( a n ) + + 255 min rhostname place ( ) + + \ get secret for authenticating ourselves with the specified host + rhostname get_secret 0= if + ." No CHAP secret found for authenticating us to " rhostname count type cr + then ( ) + + \ cancel response timeout if necessary + chap-clientstate RESPONSE = if + ['] chap_responsetimeout 0 untimeout + then + + 0 chap-resp-transmits ! ( ) + + \ generate MD based on negotiated type + chap-resp-type case \ only MD5 is defined for now + CHAP_DIGEST_MD5 of ( ) + MD5Init + chap-resp-id 1 MD5Update + secret count MD5Update + rchallenge count MD5Update + MD5Final + md5digest chap-response 16 move + chap_sendresponse + endof + ( default ) + ." unknown digest type " chap-resp-type . cr + endcase +; + +\ Receive and process response. +: chap_receiveresponse ( a n id -- ) + \ ." chap_receiveresponse" cr + 3drop +; + +: ?print ( a n -- ) dup if 2dup type then 2drop ; + +\ Receive Success +: chap_receivesuccess ( a n id -- ) + drop + + \ Answer to a duplicate response? + chap-clientstate OPENED = if 2drop exit then ( a n ) + + \ should not happen + chap-clientstate RESPONSE <> if exit then ( a n ) + + ['] chap_responsetimeout 0 untimeout ( a n ) + + \ Print the message + ?print ( ) + + OPENED set-chap-state + 4 auth_withpeer_success \ CHAP_WITHPEER +; + +\ Receive failure. +: chap_receivefailure ( a n id -- ) + drop + \ should not happen + chap-clientstate RESPONSE <> if 2drop exit then ( a n ) + + ['] chap_ResponseTimeout 0 untimeout ( a n ) + + \ Print the message + ?print ( ) + + 4 auth_withpeer_fail +; + +\ Input CHAP packet. +: chap_input ( a n -- ) + dup HEADERLEN < if 2drop exit then ( a n ) + + >r + dup 2+ be-w@ dup HEADERLEN < if ( a len ) + r> 3drop exit + then ( a len ) + dup r> > if 2drop exit then ( a n ) + + over >r ( a n r: a ) + HEADERLEN /string ( a n r: a ) + r> be-w@ wbsplit case ( a n id [sel] ) + CHAP_CHALLENGE of chap_receivechallenge endof + CHAP_RESPONSE of chap_receiveresponse endof + CHAP_FAILURE of chap_receivefailure endof + CHAP_SUCCESS of chap_receivesuccess endof + ( default ) \ Need code reject? + 3drop + ." Unknown CHAP code received. " cr + endcase +; + +\ LICENSE_BEGIN +\ Copyright (c) 2006 FirmWorks +\ +\ Permission is hereby granted, free of charge, to any person obtaining +\ a copy of this software and associated documentation files (the +\ "Software"), to deal in the Software without restriction, including +\ without limitation the rights to use, copy, modify, merge, publish, +\ distribute, sublicense, and/or sell copies of the Software, and to +\ permit persons to whom the Software is furnished to do so, subject to +\ the following conditions: +\ +\ The above copyright notice and this permission notice shall be +\ included in all copies or substantial portions of the Software. +\ +\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +\ +\ LICENSE_END diff --git a/src/ofw/ppp/const.fth b/src/ofw/ppp/const.fth new file mode 100644 index 0000000..26ed4f7 --- /dev/null +++ b/src/ofw/ppp/const.fth @@ -0,0 +1,133 @@ +\ See license at end of file +purpose: PPP global constants + +decimal + +2 constant CILEN_VOID + +\ Values for phase - used inline: +\ 0 constant PHASE_DEAD +\ 1 constant PHASE_ESTABLISH +\ 2 constant PHASE_AUTHENTICATE +\ 3 constant PHASE_NETWORK +\ 4 constant PHASE_TERMINATE + +\ Packet header = Code, id, length. +4 constant HEADERLEN + +\ CP (LCP, IPCP, etc.) codes. +1 constant CONFREQ \ Configuration Request +2 constant CONFACK \ Configuration Ack +3 constant CONFNAK \ Configuration Nak +4 constant CONFREJ \ Configuration Reject +5 constant TERMREQ \ Termination Request +6 constant TERMACK \ Termination Ack +7 constant CODEREJ \ Code Reject + +string-array >msg-name + ," confreq" + ," confack" + ," confnak" + ," confrej" + ," termreq" + ," termack" + ," coderej" +end-string-array +: .msg-name ( msg -- ) 1- >msg-name count type space ; + +\ Link states. +0 constant INITIAL \ Down, hasn't been opened +1 constant STARTING \ Down, been opened +2 constant CLOSED \ Up, hasn't been opened +3 constant STOPPED \ Open, waiting for down event +4 constant CLOSING \ Terminating the connection, not open +5 constant STOPPING \ Terminating, but open +6 constant REQSENT \ We've sent a Config Request +7 constant ACKRCVD \ We've received a Config Ack +8 constant ACKSENT \ We've sent a Config Ack +9 constant OPENED \ Connection available +\ Auth states +10 constant AUTHREQ \ We've sent an Authenticate-Request +11 constant BADAUTH \ We've received a Nak +12 constant PENDING \ Auth us to peer when lower up +13 constant LISTEN \ Listening for a challenge +14 constant RESPONSE \ Sent response, waiting for status + +string-array >state-name + ," INITIAL" + ," STARTING" + ," CLOSED" + ," STOPPED" + ," CLOSING" + ," STOPPING" + ," REQSENT" + ," ACKRCVD" + ," ACKSEND" + ," OPENED" + ," AUTHREQ" + ," BADAUTH" + ," PENDING" + ," LISTEN" + ," RESPONSE" +end-string-array +: .state-name ( state -- ) >state-name count type space ; + +\ Timeouts. +8 constant DEFTIMEOUT \ Timeout time in seconds +\ 3 constant DEFTIMEOUT \ Timeout time in seconds +2 constant DEFMAXTERMREQS \ Maximum Terminate-Request transmissions +10 constant DEFMAXCONFREQS \ Maximum Configure-Request transmissions +5 constant DEFMAXNAKLOOPS \ Maximum number of nak loops + +1500 constant DEFMRU \ Try for this +128 constant MINMRU \ No MRUs below this +16384 constant MAXMRU \ Normally limit MRU to this + +\ Default number of times we receive our magic number from the peer +\ before deciding the link is looped-back. +5 constant DEFLOOPBACKFAIL + +\ Definitions for PPP Compression Control Protocol. +\ Bits in auth_pending +1 constant UPAP_WITHPEER +4 constant CHAP_WITHPEER + +4 constant PPP_HDRLEN \ octets for standard ppp header +1500 constant PPP_MRU \ default MRU = max length of info field + +h# 21 constant PPP_IP \ Internet Protocol +h# 2d constant PPP_VJC_COMP \ VJ compressed TCP +h# 2f constant PPP_VJC_UNCOMP \ VJ uncompressed TCP +h# fd constant PPP_COMP \ compressed packet +h# 8021 constant PPP_IPCP \ IP Control Protocol +h# c021 constant PPP_LCP \ Link Control Protocol +h# c023 constant PPP_PAP \ Password Authentication Protocol +h# c025 constant PPP_LQR \ Link Quality Report protocol +h# c223 constant PPP_CHAP \ Cryptographic Handshake Auth. Protocol +h# 80fd constant PPP_CCP \ Compression Control Protocol +h# fd constant PPP_CCPD \ Compression Control Protocol, data + +h# f0b8 constant PPP_GOODFCS \ Good final FCS value +\ LICENSE_BEGIN +\ Copyright (c) 2006 FirmWorks +\ +\ Permission is hereby granted, free of charge, to any person obtaining +\ a copy of this software and associated documentation files (the +\ "Software"), to deal in the Software without restriction, including +\ without limitation the rights to use, copy, modify, merge, publish, +\ distribute, sublicense, and/or sell copies of the Software, and to +\ permit persons to whom the Software is furnished to do so, subject to +\ the following conditions: +\ +\ The above copyright notice and this permission notice shall be +\ included in all copies or substantial portions of the Software. +\ +\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +\ +\ LICENSE_END diff --git a/src/ofw/ppp/dial.fth b/src/ofw/ppp/dial.fth new file mode 100644 index 0000000..95d8282 --- /dev/null +++ b/src/ofw/ppp/dial.fth @@ -0,0 +1,271 @@ +\ See license at end of file +purpose: Modem dialer package + +false value debug-dial? +false instance value echo? + +\ Z3 - reset to factory default profile 0 +\ E0 - no echo +\ V0 - numeric result codes +\ X0 - small set of result codes +\ L1 - speaker volume low +\ M1 - speaker on until CONNECT + +\ ATZ3 +\ ATE0V0X0L1 + +\ Result codes for X0: +\ 0 OK +\ 1 CONNECT +\ 2 RING +\ 3 NO CARRIER +\ 4 ERROR + +\needs select$ fload ${BP}/forth/lib/selstr.fth + +0 0 2value modem$ +0 0 2value phone# + +\ : xyzel ( -- ) " |ATZ|ATE1X0L1M2DT|+++|ATH" ; + +\ : ms ( #ms -- ) dup 5 > if ." Delay " dup .d ." Milliseconds" cr then ms ; + +: choose$ ( default$ field$ field# -- $ ) + modem$ dup if ( default$ field$ field# modem$ ) + select$ 2swap 2drop 2swap 2drop ( $ ) + else ( default$ field$ field# modem$ ) + 3drop ( default$ field$ ) + $ppp-info ( default$ ppp-info$ ) + dup if 2swap then 2drop ( $ ) + then +; +: init$ ( -- $ ) " ATZ" " modem-init$" 0 choose$ ; +: dial$ ( -- $ ) " ATDT" " modem-dial$" 1 choose$ ; +: interrupt$ ( -- $ ) " +++" " modem-interrupt$" 2 choose$ ; +: hangup$ ( -- $ ) " ATH" " modem-hangup$" 3 choose$ ; + +: rts-dtr-off ( -- ) " rts-dtr-off" $call-parent ; +: rts-dtr-on ( -- ) " rts-dtr-on" $call-parent ; +: use-irqs ( -- ) " use-irqs" $call-parent ; +: use-polling ( -- ) " use-polling" $call-parent ; +: install-abort ( -- ) " install-abort" $call-parent ; +: remove-abort ( -- ) " remove-abort" $call-parent ; + +: read ( adr len -- actual ) " read" $call-parent ; +: write ( adr len -- actual ) " write" $call-parent ; + +: reset-delay ( -- #ms ) + " reset-delay" my-parent ihandle>phandle ( name$ phandle ) + get-package-property if d# 1000 else get-encoded-int then +; + +d# 61 buffer: dial-cmd$ +: +prefix ( $1 prefix$ -- $2 ) + 2 pick over >= if ( $1 prefix$ ) + \ The string is long enough to contain the prefix + 2over 2over rot drop ( $1 prefix$ adr1 prefix$ ) + + \ If the string already begins with the prefix, don't modify it + caps-comp 0= if 2drop exit then + then + + \ Concatenate the prefix and the string + dial-cmd$ pack ( $1 adr ) + $cat dial-cmd$ count 2dup upper ( $2 ) +; + +1 buffer: ch + +0 instance value timeout +: set-timeout ( #msecs -- ) get-msecs + to timeout ; + +: getchar ( -- char ) + begin + get-msecs timeout - 0> throw + ch 1 read + 1 = until + ch c@ + echo? if dup emit ( dup carret = if linefeed emit then ) then +; + +: timed-read ( timeout-msecs -- char ) + dup 0< throw ( timeout-msecs ) + set-timeout getchar +; + +: eat ( -- ) begin 5 ['] timed-read catch nip until ; + +\ The character does not extend the current match, so we must adjust +\ the number matched. For example, if the pattern string is "ininx" +\ and we have already matched "inin", but the next character is "i" +\ instead of "x", we go back to the state where we have matched "ini". +: resync ( pattern$ #matched char -- adr len #matched' ) + >r 2 pick swap ( pattern$ adr n r: char ) + begin dup while ( pattern$ adr n r: char ) + 1 /string ( pattern$ adr' n' r: char ) + 2over 2over 2swap substring? if ( pattern$ adr' n' r: char ) + 3 pick over + c@ r@ = if ( pattern$ adr' n' r: char ) + 1+ nip r> drop exit ( pattern$ n' ) + then ( pattern$ adr' n' r: char ) + then ( pattern$ adr' n' r: char ) + repeat ( pattern$ adr' 0 r: char ) + 2drop ( pattern$ r: char ) + over c@ r> = if 1 else 0 then ( pattern$ #matched' ) +; +: expect ( pattern$ timeout -- ) + set-timeout 0 ( pattern$ #matched ) + \ Exit the loop when the entire string has been matched + begin 2dup <> while ( pattern$ #matched ) + 2 pick over + c@ getchar ( pattern$ #matched pchar char ) + + \ The input character extends the match or causes a resync + tuck = if drop 1+ else resync then ( pattern$ #matched' ) + repeat ( pattern$ #matched ) + 3drop +; +: expect? ( pattern$ timeout-ms -- timeout? ) + ['] expect catch dup if nip nip nip then +; + +: send-char-echo ( adr -- ) + dup 1 write drop ( adr ) + begin ( adr ) + 1 ['] timed-read catch if ( adr x ) + drop true ( adr flag ) + else ( adr char ) + over c@ = ( adr flag ) + then ( adr flag ) + until ( adr ) + drop +; + +\ This version is used for the "+++" interrupt string, which has +\ some weird timing requirements +: (send) ( $ -- ) bounds ?do i 1 write drop d# 100 ms loop ; + +: send ( $ -- ) bounds ?do i 1 write drop loop " "r" write drop ; + +: wait-ok ( #msecs -- timeout? ) " OK"r"n" rot expect? ; +: interrupt-modem ( -- timeout? ) + d# 1500 ms interrupt$ (send) d# 2000 wait-ok +; +: sw-hangup ( -- ) + interrupt-modem 0= if + hangup$ send d# 1000 wait-ok drop + then + rts-dtr-off \ Hangup in a hardware way too + d# 4000 ms \ Give the other end time to see the hangup +; +: handshake ( -- error? ) + init$ send d# 5000 wait-ok if + interrupt-modem if true exit then + init$ send d# 5000 wait-ok if true exit then + then + reset-delay ms \ DIVA ISDN + false +; +: hangup ( -- ) sw-hangup ; + +d# 80 instance buffer: linebuf +: +byte ( char -- ) + linebuf c@ d# 79 >= if drop exit then ( char ) + linebuf count + c! linebuf c@ 1+ linebuf c! +; +: (get-line) ( timeout -- ) + set-timeout + 0 linebuf c! + begin + getchar case + carret of exit endof + linefeed of endof + ( default ) dup +byte + endcase + again +; + +: get-line ( timeout -- true | adr len false ) + ['] (get-line) catch if drop true exit then + linebuf count false +; + +: run-login-script ( -- ) + 6 1 do + i <# u# " expect$" hold$ u#> $ppp-info ( expect$ ) + dup if d# 20,000 expect else 2drop then ( ) + + i <# u# " send$" hold$ u#> $ppp-info ( send$ ) + dup if send else 2drop then ( ) + loop +; + +: login? ( -- okay? ) + " script" $ppp-info ( adr len ) + 2dup " Use Terminal Window" $= if 2drop itip true exit then + " Run Login Script" $= if ['] run-login-script catch 0= exit then + true +; + +: open ( -- okay? ) + debug-dial? if true to echo? then + use-irqs + + my-args [char] | split-string to modem$ to phone# ( ) + + handshake if + ." Can't initialize modem" cr + false exit + then + + phone# dup 0= if 2drop " phone#" $ppp-info then ( phone#$ ) + + dial$ +prefix send + + \ Eat the echoed dial command line + d# 1000 get-line if false exit then ( adr len ) + 2drop ( ) + + \ Instead of using expect, we get a line, so we can recognize + \ errors (BUSY, etc) quickly, instead of waiting for a timeout. + + \ Wait for a response (CONNECT, BUSY, etc) + d# 120,000 get-line if false exit then ( adr len ) + + \ If the line is empty, it's an extra carriage return; + \ get the next one. + dup 0= if + 2drop d# 1000 get-line if false exit then + then + + " "n" d# 200 expect? drop ( adr len ) \ Eat the linefeed + + \ If not CONNECT, the result could be BUSY, NO DIALTONE, ERROR, etc + " CONNECT" 2swap substring? 0= if false exit then + + login? ( okay? ) + + false to echo? +; +: close ( -- ) debug-dial? if true to echo? then hangup ; +\ LICENSE_BEGIN +\ Copyright (c) 2006 FirmWorks +\ +\ Permission is hereby granted, free of charge, to any person obtaining +\ a copy of this software and associated documentation files (the +\ "Software"), to deal in the Software without restriction, including +\ without limitation the rights to use, copy, modify, merge, publish, +\ distribute, sublicense, and/or sell copies of the Software, and to +\ permit persons to whom the Software is furnished to do so, subject to +\ the following conditions: +\ +\ The above copyright notice and this permission notice shall be +\ included in all copies or substantial portions of the Software. +\ +\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +\ +\ LICENSE_END diff --git a/src/ofw/ppp/fcs.fth b/src/ofw/ppp/fcs.fth new file mode 100644 index 0000000..df56a37 --- /dev/null +++ b/src/ofw/ppp/fcs.fth @@ -0,0 +1,72 @@ +\ See license at end of file +purpose: PPP Frame Check Sequence (FCS) + +hex + +\ 256 entry FCS lookup table +create fcstab + 0000 w, 1189 w, 2312 w, 329b w, 4624 w, 57ad w, 6536 w, 74bf w, + 8c48 w, 9dc1 w, af5a w, bed3 w, ca6c w, dbe5 w, e97e w, f8f7 w, + 1081 w, 0108 w, 3393 w, 221a w, 56a5 w, 472c w, 75b7 w, 643e w, + 9cc9 w, 8d40 w, bfdb w, ae52 w, daed w, cb64 w, f9ff w, e876 w, + 2102 w, 308b w, 0210 w, 1399 w, 6726 w, 76af w, 4434 w, 55bd w, + ad4a w, bcc3 w, 8e58 w, 9fd1 w, eb6e w, fae7 w, c87c w, d9f5 w, + 3183 w, 200a w, 1291 w, 0318 w, 77a7 w, 662e w, 54b5 w, 453c w, + bdcb w, ac42 w, 9ed9 w, 8f50 w, fbef w, ea66 w, d8fd w, c974 w, + 4204 w, 538d w, 6116 w, 709f w, 0420 w, 15a9 w, 2732 w, 36bb w, + ce4c w, dfc5 w, ed5e w, fcd7 w, 8868 w, 99e1 w, ab7a w, baf3 w, + 5285 w, 430c w, 7197 w, 601e w, 14a1 w, 0528 w, 37b3 w, 263a w, + decd w, cf44 w, fddf w, ec56 w, 98e9 w, 8960 w, bbfb w, aa72 w, + 6306 w, 728f w, 4014 w, 519d w, 2522 w, 34ab w, 0630 w, 17b9 w, + ef4e w, fec7 w, cc5c w, ddd5 w, a96a w, b8e3 w, 8a78 w, 9bf1 w, + 7387 w, 620e w, 5095 w, 411c w, 35a3 w, 242a w, 16b1 w, 0738 w, + ffcf w, ee46 w, dcdd w, cd54 w, b9eb w, a862 w, 9af9 w, 8b70 w, + 8408 w, 9581 w, a71a w, b693 w, c22c w, d3a5 w, e13e w, f0b7 w, + 0840 w, 19c9 w, 2b52 w, 3adb w, 4e64 w, 5fed w, 6d76 w, 7cff w, + 9489 w, 8500 w, b79b w, a612 w, d2ad w, c324 w, f1bf w, e036 w, + 18c1 w, 0948 w, 3bd3 w, 2a5a w, 5ee5 w, 4f6c w, 7df7 w, 6c7e w, + a50a w, b483 w, 8618 w, 9791 w, e32e w, f2a7 w, c03c w, d1b5 w, + 2942 w, 38cb w, 0a50 w, 1bd9 w, 6f66 w, 7eef w, 4c74 w, 5dfd w, + b58b w, a402 w, 9699 w, 8710 w, f3af w, e226 w, d0bd w, c134 w, + 39c3 w, 284a w, 1ad1 w, 0b58 w, 7fe7 w, 6e6e w, 5cf5 w, 4d7c w, + c60c w, d785 w, e51e w, f497 w, 8028 w, 91a1 w, a33a w, b2b3 w, + 4a44 w, 5bcd w, 6956 w, 78df w, 0c60 w, 1de9 w, 2f72 w, 3efb w, + d68d w, c704 w, f59f w, e416 w, 90a9 w, 8120 w, b3bb w, a232 w, + 5ac5 w, 4b4c w, 79d7 w, 685e w, 1ce1 w, 0d68 w, 3ff3 w, 2e7a w, + e70e w, f687 w, c41c w, d595 w, a12a w, b0a3 w, 8238 w, 93b1 w, + 6b46 w, 7acf w, 4854 w, 59dd w, 2d62 w, 3ceb w, 0e70 w, 1ff9 w, + f78f w, e606 w, d49d w, c514 w, b1ab w, a022 w, 92b9 w, 8330 w, + 7bc7 w, 6a4e w, 58d5 w, 495c w, 3de3 w, 2c6a w, 1ef1 w, 0f78 w, + +\ fcs = (fcs >> 8) ^ fcstab[(fcs ^ *cp++) & ff]; +: update-fcs ( byte fcs -- fcs' ) + wbsplit ( byte low high ) + swap rot xor ( high low^byte ) + fcstab swap wa+ w@ xor ( fcs' ) +; +: fcs ( a n -- fcs ) + ffff -rot bounds ?do i c@ swap update-fcs loop +; +\ LICENSE_BEGIN +\ Copyright (c) 2006 FirmWorks +\ +\ Permission is hereby granted, free of charge, to any person obtaining +\ a copy of this software and associated documentation files (the +\ "Software"), to deal in the Software without restriction, including +\ without limitation the rights to use, copy, modify, merge, publish, +\ distribute, sublicense, and/or sell copies of the Software, and to +\ permit persons to whom the Software is furnished to do so, subject to +\ the following conditions: +\ +\ The above copyright notice and this permission notice shall be +\ included in all copies or substantial portions of the Software. +\ +\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +\ +\ LICENSE_END diff --git a/src/ofw/ppp/framing.fth b/src/ofw/ppp/framing.fth new file mode 100644 index 0000000..1a302db --- /dev/null +++ b/src/ofw/ppp/framing.fth @@ -0,0 +1,205 @@ +\ See license at end of file +purpose: PPP Framing + +hex + +0 value read-xt +[ifdef] testing +0 value ih-com +: open-com ( -- error? ) + " com2:38400" open-dev to ih-com + ih-com 0= +; + +\ restore the terminal device and close it. +: close-com ( -- ) + " close" ih-com $call-method + -1 to ih-com +; +\ : tty-read ( a n -- actual ) " read" ih-com $call-method ; +: tty-read ( a n -- actual ) read-xt ih-com call-package ; +: tty-write ( a n -- actual ) " write" ih-com $call-method ; + +[else] +: open-com ( -- false ) false ; +: close-com ( -- ) ; +\ : tty-read ( a n -- actual ) " read" $call-parent ; +: tty-read ( a n -- actual ) read-xt my-parent call-package ; +: tty-write ( a n -- actual ) " write" $call-parent ; +[then] + +\ Async-Control-Character-Maps +create rACCM -1 , +create tACCM -1 , ( -1 , -1 , -1 , -1 , -1 , -1 , -1 , ) + +: bit@ ( n a -- bit ) + \ swap 20 /mod rot + \ uncomment this line for long tACCM + @ 1 rot lshift and +; + +PPP_MRU 10 + 2* buffer: encode-buf +0 value encode-ptr +: +encode ( c -- ) + encode-ptr c! 1 encode-ptr + to encode-ptr +; +: encode? ( c -- encode? ) + dup 7d 7e between + swap dup 20 < if tACCM bit@ or else drop then +; +: encoder ( a1 n1 -- a2 n2 ) + encode-buf to encode-ptr + 7e +encode + PPP_MRU min bounds ?do + i c@ dup encode? if + 7d +encode 20 xor + then + +encode + loop + 7e +encode + encode-buf encode-ptr over - +; +: add-fcs ( a n1 -- a n2 ) + 2dup fcs ffff xor >r 2dup + r> swap le-w! 2+ +; + +PPP_MRU 10 + 2* buffer: outbuf +: ppp-write ( a n -- actual ) + PPP_MRU min over >r 4 /string r> be-l@ lwsplit outbuf swap ( a n proto out ac ) + comp_ac if drop else putw then swap ( a n out proto ) + dup h# ff00 and 0= comp_proto and if putc else putw then ( a n out ) + 2dup + >r + swap move + outbuf r> over - + show-packets? if ." S " dup 3 u.r ." : " 2dup cdump cr then ( a n ) + add-fcs encoder tty-write +; + + +PPP_MRU d# 10 + constant /inbuf +/inbuf buffer: inbuf +0 value inptr +0 value current-fcs +false value escaping? +false value resyncing? +false value framed? + +: (init-framer) ( -- ) + 0 to inptr + false to framed? + false to escaping? + false to resyncing? + h# ffff to current-fcs +; +: init-framer ( -- ) + " read" my-parent ihandle>phandle find-method if to read-xt then + (init-framer) +; + +: +inbuf ( byte -- ) + inptr /inbuf = if \ Packet too long; we must have lost a framing byte + drop + (init-framer) true to resyncing? + exit + then + dup current-fcs update-fcs to current-fcs + inbuf inptr + c! 1 inptr + to inptr +; +: 1decode ( byte -- ) + resyncing? if + h# 7e = if false to resyncing? then + exit + then + + dup h# 7e = if + drop true to framed? exit + then + + escaping? if + h# 20 xor +inbuf false to escaping? exit + then + + dup h# 7d = if + drop true to escaping? exit + then + + dup h# 20 < if + dup rACCM bit@ if drop else +inbuf then exit + then + + +inbuf +; + +: packet-okay? ( -- false | adr len true ) + inbuf inptr current-fcs ( adr len fcs ) + (init-framer) ( adr len fcs ) + + \ Silently discard empty frames + over 0= if 3drop false exit then ( adr len fcs ) + + \ Discard frames with bad FCS + \ We need to figure out some way to report this up to the IP layer + \ for the benefit of the VJ header compression code, which needs to + \ know when link errors occur. + PPP_GOODFCS <> if ( adr len ) + \ ." FCS " + 2drop false exit + then ( adr len ) + + 2- \ Lose the FCS ( adr len ) + + \ Discard too-short frames + \ We should report these errors too + dup 4 < if ( adr len ) + ." RUNT " + 2drop false exit + then ( adr len ) + + \ Remove the address (0xff) and control (0x03) bytes, if any, from + \ the start of the frame + over " "(ff 03)" comp 0= if ( adr len ) + 2 /string ( adr' len' ) + then ( adr len ) + + true ( adr len true ) +; + +variable the-byte +: poll-packet ( -- hangup? false | adr len true ) + begin the-byte 1 tty-read dup 0> while ( 1 ) + drop + the-byte c@ 1decode + framed? if packet-okay? if + show-packets? if ." R " dup 3 u.r ." : " 2dup cdump cr then + true exit + then then + repeat ( read-result ) + + \ Return hangup?=true when the line drops + -1 = if true false exit then ( ) + + \ Return hangup?=false while we are still polling + false false +; +\ LICENSE_BEGIN +\ Copyright (c) 2006 FirmWorks +\ +\ Permission is hereby granted, free of charge, to any person obtaining +\ a copy of this software and associated documentation files (the +\ "Software"), to deal in the Software without restriction, including +\ without limitation the rights to use, copy, modify, merge, publish, +\ distribute, sublicense, and/or sell copies of the Software, and to +\ permit persons to whom the Software is furnished to do so, subject to +\ the following conditions: +\ +\ The above copyright notice and this permission notice shall be +\ included in all copies or substantial portions of the Software. +\ +\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +\ +\ LICENSE_END diff --git a/src/ofw/ppp/fsm.fth b/src/ofw/ppp/fsm.fth new file mode 100644 index 0000000..6d44152 --- /dev/null +++ b/src/ofw/ppp/fsm.fth @@ -0,0 +1,446 @@ +\ See license at end of file +purpose: Finite State Machines for PPP + +\ Each FSM is described by a data structure and a set of callbacks. + +struct + /token field >resetci \ Reset our Configuration Information + /token field >cilen \ Length of our Configuration Information + /token field >addci \ Add our Configuration Information + /token field >ackci \ ACK our Configuration Information + /token field >nakci \ NAK our Configuration Information + /token field >rejci \ Reject our Configuration Information + /token field >reqci \ Request peer's Configuration Information + /token field >up \ Called when fsm reaches OPENED state + /token field >down \ Called when fsm leaves OPENED state + /token field >finished \ Called when we don't want the lower layer + /token field >extcode \ Called when unknown code received +constant /fsm_callbacks + +struct + /n field >protocol \ Data Link Layer Protocol field value + /n field >retransmits \ Number of retransmissions left + /n field >nakloops \ Number of nak loops since last ack + /fsm_callbacks field >callbacks \ Callback routines + 1 field >f_state \ State + 1 field >id \ Current id + 1 field >reqid \ Current request id + 1 field >seen_ack \ Have received valid Ack/Nak/Rej to Req +constant /fsm + +/fsm buffer: lcp-fsm +/fsm buffer: ipcp-fsm +/fsm buffer: ccp-fsm + +0 value thefsm + +\ Callbacks +: do-callback ( fsm+index -- ) >callbacks token@ execute ; + +: resetci ( -- ) thefsm >resetci do-callback ; +: cilen ( -- len ) thefsm >cilen do-callback ; +: addci ( a n -- residue ) thefsm >addci do-callback ; +: ackci ( a n -- good? ) thefsm >ackci do-callback ; +: nakci ( a n -- good? ) thefsm >nakci do-callback ; +: rejci ( a n -- good? ) thefsm >rejci do-callback ; +: reqci ( a n rej? -- n2 res ) thefsm >reqci do-callback ; +: finished ( -- ) thefsm >finished do-callback ; +: extcode ( a n code id -- flag ) thefsm >extcode do-callback ; +: go-down ( -- ) thefsm >down do-callback ; +: go-up ( -- ) thefsm >up do-callback ; + +: this-id ( -- n ) thefsm >reqid c@ ; + +: next-id ( fsm -- n ) + dup >id dup c@ 1+ dup rot c! + dup rot >reqid c! +; + +: .fsm ( state fsm -- ) + case + lcp-fsm of ." lcp " .state-name endof + ipcp-fsm of ." ipcp " .state-name endof + ccp-fsm of ." ccp " .state-name endof + >r ." FSM: " . ." state: " . r> + endcase +; +: set-state ( state -- ) + show-states? if dup thefsm .fsm then + thefsm >f_state c! +; +: thestate ( -- n ) thefsm >f_state c@ ; +: set-fsm ( fsm -- state ) to thefsm thestate ; + +: set-retransmits ( n -- ) thefsm >retransmits ! ; +: decr-retransmits ( -- ) -1 thefsm >retransmits +! ; +: retransmits-done? ( -- done? ) thefsm >retransmits @ 0<= ; + +\ Send some data. +\ Used for all packets sent to our peer by this module. +: fsm_send ( data datalen code id fsm -- ) + >r + \ Adjust length to be smaller than MTU + 2swap peer_mru HEADERLEN - umin ( code id data datalen ) + tuck outpacket_buf PPP_HDRLEN + HEADERLEN + swap move + HEADERLEN + ( code id outlen ) + r> >protocol @ outpacket_buf makeheader ( code id outlen a ) + >r rot r@ c! swap r@ 1+ c! dup r> 2+ be-w! ( outlen ) + outpacket_buf swap PPP_HDRLEN + + ppp-write drop +; + +: send-termreq ( -- ) 0 0 TERMREQ thefsm next-id thefsm fsm_send ; +: send-termack ( id -- ) >r 0 0 TERMACK r> thefsm fsm_send ; + +defer fsm_timeout +: set-timer ( -- ) ['] fsm_timeout thefsm DEFTIMEOUT timeout ; +: end-timer ( -- ) ['] fsm_timeout thefsm untimeout ; + +\ Send a Configure-Request. +: fsm_sconfreq ( retransmit? -- ) + thestate dup REQSENT <> over ACKRCVD <> and swap ACKSENT <> and if + \ Not currently negotiating - reset options + resetci + 0 thefsm >nakloops ! + then ( retransmit? ) + + 0= if + \ New request - reset retransmission counter, use new ID + DEFMAXCONFREQS set-retransmits + thefsm next-id drop + then + + false thefsm >seen_ack c! + + \ Make up the request packet + outpacket_buf PPP_HDRLEN + HEADERLEN + ( a ) + + cilen peer_mru HEADERLEN - min ( a n ) + 2dup addci if ( this should never happen ) then ( a n ) + + \ send the request to our peer + CONFREQ thefsm >reqid c@ thefsm fsm_send + + \ start the retransmit timer + decr-retransmits + set-timer +; +: initial-confreq ( -- ) 0 fsm_sconfreq ; +: initial-confreq-send ( -- ) 0 fsm_sconfreq REQSENT set-state ; + +: fsm_tocl ( -- ) + retransmits-done? if + \ ." We've waited for an ack long enough. Peer probably heard us." cr + thestate CLOSING = if CLOSED else STOPPED then set-state + finished + else + send-termreq set-timer decr-retransmits + then +; +: fsm_to ( -- ) + retransmits-done? if + STOPPED set-state finished + else + 1 fsm_sconfreq thestate ACKRCVD = if REQSENT set-state then + then +; + +\ Timeout expired. +: (fsm_timeout) ( fsm -- ) + thefsm >r + set-fsm case + CLOSING of fsm_tocl endof + STOPPING of fsm_tocl endof + REQSENT of fsm_to endof + ACKRCVD of fsm_to endof + ACKSENT of fsm_to endof + endcase + r> to thefsm +; +' (fsm_timeout) to fsm_timeout + + +\ Finite State Machine + +\ Initialize fsm state. +: fsm_init ( fsm -- ) + dup set-fsm drop + INITIAL set-state + 0 swap >id c! +; + +\ The lower layer is up. +: fsm_lowerup ( fsm -- ) + set-fsm case + INITIAL of CLOSED set-state endof + STARTING of initial-confreq-send endof + endcase +; + +\ The lower layer is down. +\ Cancel all timeouts and inform upper layers. +: fsm_lowerdown ( fsm -- ) + set-fsm case + CLOSED of INITIAL set-state endof + STOPPED of STARTING set-state endof + CLOSING of INITIAL set-state end-timer endof + STOPPING of STARTING set-state end-timer endof + REQSENT of STARTING set-state end-timer endof + ACKRCVD of STARTING set-state end-timer endof + ACKSENT of STARTING set-state end-timer endof + OPENED of go-down STARTING set-state endof + endcase +; + +\ Link is allowed to come up. +: fsm_open ( fsm -- ) + set-fsm case + INITIAL of STARTING set-state endof + CLOSED of initial-confreq-send endof + CLOSING of STOPPING set-state endof + endcase +; + +: fsm_closing ( -- ) + thestate OPENED <> if end-timer else go-down then + + DEFMAXTERMREQS set-retransmits + send-termreq + set-timer + decr-retransmits + CLOSING set-state +; + +\ Cancel timeouts and either initiate close or possibly go directly to +\ the CLOSED state. +: fsm_close ( fsm -- ) + set-fsm case + STARTING of INITIAL set-state endof + STOPPED of CLOSED set-state endof + STOPPING of CLOSING set-state endof + REQSENT of fsm_closing endof + ACKRCVD of fsm_closing endof + ACKSENT of fsm_closing endof + OPENED of fsm_closing endof + endcase +; + + +\ Receive Configure-Request. +: fsm_rconfreq ( inp len id -- ) + thestate case + CLOSED of ( inp len id ) nip nip send-termack exit endof + CLOSING of ( inp len id ) 3drop exit endof + STOPPING of ( inp len id ) 3drop exit endof + OPENED of go-down initial-confreq endof + STOPPED of initial-confreq-send endof + endcase ( inp len id ) + + \ Pass the requested configuration options + \ to protocol-specific code for checking. + 2 pick rot thefsm >nakloops @ DEFMAXNAKLOOPS >= ( inp id inp len rej? ) + reqci ( inp id n code ) + \ send the Ack, Nak or Rej to the peer + rot over thefsm swap >r ( inp n code id fsm ) + fsm_send r> ( code ) + dup CONFACK = if + drop ( ) + thestate ACKRCVD = if + end-timer + OPENED set-state + go-up + else + ACKSENT set-state + then + 0 thefsm >nakloops ! + else ( code ) + \ we sent CONFACK or CONFREJ + thestate ACKRCVD <> if REQSENT set-state then ( code ) + CONFNAK = if 1 thefsm >nakloops +! then ( ) + then ( ) +; + +\ Receive Configure-Ack. +: fsm_rconfack ( a n id -- ) + \ Exit if not the expected id + dup thefsm >reqid c@ <> thefsm >seen_ack c@ or if 3drop exit then + + 3dup drop ackci 0= if 3drop exit then ( a n id ) \ ignore Ack + + 1 thefsm >seen_ack c! ( a n id ) + + thestate case ( a n id [state] ) + CLOSED of nip nip send-termack endof ( ) + STOPPED of nip nip send-termack endof ( ) + REQSENT of + 3drop ACKRCVD set-state DEFMAXCONFREQS set-retransmits + endof + ACKRCVD of ( a n id ) + \ ." An extra valid Ack?" cr + 3drop end-timer initial-confreq-send + endof + ACKSENT of ( a n id ) + 3drop end-timer OPENED set-state + DEFMAXCONFREQS set-retransmits go-up + endof + OPENED of 3drop go-down initial-confreq-send endof + endcase +; + +\ Receive Configure-Nak or Configure-Reject. +: fsm_rconfnakrej ( a n code id -- ) + \ Exit if not the expected id + thefsm >reqid c@ <> thefsm >seen_ack c@ or if 3drop exit then + ( a n code ) + + CONFNAK = if 2dup nakci else 2dup rejci then ( a n ret ) + dup 0= if 3drop exit then ( a n ret ) + + 1 thefsm >seen_ack c! ( a n ret ) + + thestate case + CLOSED of ( a n ret ) + 3drop ( ) + this-id send-termack + endof + STOPPED of ( a n ret ) + 3drop ( ) + this-id send-termack + endof + REQSENT of ( a n ret ) + \ ." They didn't agree to what we wanted - try another request" cr + nip nip end-timer + 0> if + STOPPED set-state \ kludge for stopping CCP + else + initial-confreq + then + endof + + ACKSENT of ( a n ret ) + \ ." They didn't agree to what we wanted - try another request..." cr + nip nip end-timer + 0> if + STOPPED set-state \ kludge for stopping CCP + else + initial-confreq + then + endof + + ACKRCVD of ( a n ret ) + \ ." Got a Nak/reject when we had already had an Ack??" cr + 3drop end-timer initial-confreq-send + endof + + OPENED of ( a n ret ) + 3drop go-down initial-confreq-send + endof + endcase +; + +\ Receive Terminate-Req. +: fsm_rtermreq ( id -- ) + thestate case + ACKRCVD of REQSENT set-state endof \ Start over and keep trying + ACKSENT of REQSENT set-state endof \ Start over and keep trying + OPENED of + \ ." terminated at peer's request" cr + go-down 0 set-retransmits STOPPING set-state set-timer + endof + endcase ( id ) + send-termack +; + +\ Receive Terminate-Ack. +: fsm_rtermack ( -- ) + thestate case + CLOSING of end-timer CLOSED set-state finished endof + STOPPING of end-timer STOPPED set-state finished endof + ACKRCVD of REQSENT set-state endof + OPENED of go-down initial-confreq endof + endcase +; + +\ Receive an Code-Reject. +: fsm_rcoderej ( len -- ) + HEADERLEN < if exit then + thestate ACKRCVD = if REQSENT set-state then +; + +\ Peer doesn't speak this protocol. +\ Treat this as a catastrophic error (RXJ-). +: fsm_protreject ( fsm -- ) + dup set-fsm case + CLOSING of end-timer CLOSED set-state finished endof + CLOSED of CLOSED set-state finished endof + STOPPING of end-timer STOPPED set-state finished endof + REQSENT of end-timer STOPPED set-state finished endof + ACKRCVD of end-timer STOPPED set-state finished endof + ACKSENT of end-timer STOPPED set-state finished endof + STOPPED of STOPPED set-state finished endof + OPENED of + go-down + DEFMAXTERMREQS set-retransmits + send-termreq set-timer decr-retransmits STOPPING set-state + endof + endcase +; + +\ Input packet. +: fsm_input ( a n fsm -- ) + set-fsm drop + dup HEADERLEN < if 2drop exit then ( a n ) + over wa1+ be-w@ dup HEADERLEN < if 2drop exit then ( a n len ) + tuck < if 2drop exit then ( a len ) + + HEADERLEN /string + + thestate dup INITIAL = swap STARTING = or if ( a len ) + 2drop exit + then ( a len ) + + \ Action depends on code. + over HEADERLEN - dup c@ swap ca1+ c@ ( a len code id ) + over case ( a len code id [code]) + CONFREQ of nip fsm_rconfreq endof ( ) + CONFACK of nip fsm_rconfack endof ( ) + CONFNAK of fsm_rconfnakrej endof ( ) + CONFREJ of fsm_rconfnakrej endof ( ) + TERMREQ of >r 3drop r> fsm_rtermreq endof ( ) + TERMACK of 4drop fsm_rtermack endof ( ) + CODEREJ of 2drop nip fsm_rcoderej endof ( ) + ( default ) ( a len code id code ) + drop ( a len code id ) + 4dup extcode if ( a len code id ) + 4drop ( ) + else ( a len code id ) + >r drop HEADERLEN negate /string CODEREJ r> ( a len code id ) + thefsm fsm_send ( ) + then ( ) + 0 ( fodder ) + endcase ( ) +; + +\ LICENSE_BEGIN +\ Copyright (c) 2006 FirmWorks +\ +\ Permission is hereby granted, free of charge, to any person obtaining +\ a copy of this software and associated documentation files (the +\ "Software"), to deal in the Software without restriction, including +\ without limitation the rights to use, copy, modify, merge, publish, +\ distribute, sublicense, and/or sell copies of the Software, and to +\ permit persons to whom the Software is furnished to do so, subject to +\ the following conditions: +\ +\ The above copyright notice and this permission notice shall be +\ included in all copies or substantial portions of the Software. +\ +\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +\ +\ LICENSE_END diff --git a/src/ofw/ppp/ip.fth b/src/ofw/ppp/ip.fth new file mode 100644 index 0000000..12551d4 --- /dev/null +++ b/src/ofw/ppp/ip.fth @@ -0,0 +1,106 @@ +\ See license at end of file +purpose: PPP IP + +\ incoming packets are saved in a single large buffer, each +\ preceded by a 16-bit count + +defer get_input + +inpacket_max 4 * constant /ipin_bufs +/ipin_bufs buffer: ipin_bufs +0 value ipin +: ipin-sane ( -- ) + ipin ipin_bufs u< if ipin_bufs to ipin then + ipin ipin_bufs /ipin_bufs + u> if + ipin_bufs /ipin_bufs + to ipin + then +; +: ip-any? ( -- any? ) ipin ipin_bufs u> ; +: iproom ( -- n ) ipin_bufs /ipin_bufs + ipin - ; +: $ipin-add ( a n -- ) + iproom dup 2 > if ( a n room ) + 2- min + ipin over putw + 2dup + to ipin + swap move + else + 3drop + then +; +: $ipin-del ( -- ) + ipin_bufs getw dup 2+ >r + ipin_bufs ( second first ) + ipin over - r@ - ( second first len ) + move ipin r> - to ipin +; +: $ipin ( -- a n ) ipin_bufs getw ; +: ip_input ( a n -- ) + ppp-is-open 0= if 2drop exit then + ipin-sane + $ipin-add +; +: read ( a n -- actual ) + ipin-sane + get_input + ip-any? if + 2dup erase + over d# 12 + h# 800 swap be-w! + d# 14 /string + ipin_bufs getw rot min + >r swap r@ move + $ipin-del + r> d# 14 + + else + 2drop -2 + then +\ dup 0> if ." r" dup . then +; +variable ipid +: nextid ( -- n ) + 1 ipid +! ipid c@ +; +: write ( a n -- actual ) + d# 14 /string + peer_mru HEADERLEN - umin >r ( a ) + PPP_IP outpacket_buf makeheader ( a b ) + r@ move + outpacket_buf r@ PPP_HDRLEN + ppp-write drop + r> d# 14 + +\ dup 0> if ." w" dup . then +; +: load ( adr -- len ) + " obp-tftp" find-package if ( adr phandle ) + my-args rot open-package ( adr ihandle|0 ) + else ( adr ) + 0 ( adr 0 ) + then ( adr ihandle|0 ) + + dup 0= if ." Can't open obp-tftp support package" abort then + ( adr ihandle ) + + >r + " load" r@ $call-method ( len ) + r> close-package +; +\ LICENSE_BEGIN +\ Copyright (c) 2006 FirmWorks +\ +\ Permission is hereby granted, free of charge, to any person obtaining +\ a copy of this software and associated documentation files (the +\ "Software"), to deal in the Software without restriction, including +\ without limitation the rights to use, copy, modify, merge, publish, +\ distribute, sublicense, and/or sell copies of the Software, and to +\ permit persons to whom the Software is furnished to do so, subject to +\ the following conditions: +\ +\ The above copyright notice and this permission notice shall be +\ included in all copies or substantial portions of the Software. +\ +\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +\ +\ LICENSE_END diff --git a/src/ofw/ppp/ipcp.fth b/src/ofw/ppp/ipcp.fth new file mode 100644 index 0000000..8491065 --- /dev/null +++ b/src/ofw/ppp/ipcp.fth @@ -0,0 +1,959 @@ +\ See license at end of file +purpose: IPCP -- PPP IP Control Protocol + +decimal + +1 constant CI_ADDRS \ IP Addresses +2 constant CI_COMPRESSTYPE \ Compression Type +3 constant CI_ADDR + +4 constant CILEN_COMPRESS \ min length for compression protocol opt. +6 constant CILEN_VJ +6 constant CILEN_ADDR +10 constant CILEN_ADDRS + +129 constant CI_MS_DNS1 \ Primary DNS value +131 constant CI_MS_DNS2 \ Secondary DNS value + +16 constant MAX_STATES \ from slcompress.h +h# 002d constant IPCP_VJ_COMP \ current value for VJ compression option +h# 0037 constant IPCP_VJ_COMP_OLD \ obsolete value for VJ compression option + +\ IPCP options +struct + 4 field >ouraddr \ Addresses in NETWORK BYTE ORDER + 4 field >hisaddr + + 4 field >dnsaddr0 + 4 field >dnsaddr1 + + 2 field >vj_protocol \ protocol value to use in VJ option + 1 field >neg_addr \ Negotiate IP Address? + 1 field >old_addrs \ Use old (IP-Addresses) option? + + 1 field >req_addr \ Ask peer to send IP address? + 1 field >neg_vj \ Van Jacobson Compression? + 1 field >old_vj \ use old (2 field) form of VJ option? + 1 field >accept_local \ accept peer's value for ouraddr + + 1 field >accept_remote \ accept peer's value for hisaddr + 1 field >maxslotindex \ values for RFC1332 VJ compression neg. + 1 field >cflag + 1 field >neg_dns \ Negotiate DNS Address? +constant /ipcp + +/ipcp buffer: ipcp-want +/ipcp buffer: ipcp-allow +/ipcp buffer: ipcp-got +/ipcp buffer: ipcp-his +/ipcp buffer: ipcp-nope \ options we've seen Naks for +/ipcp buffer: ipcp-try \ options to request next time + +0 value cis_received \ # Conf-Reqs received + +\ Frequently used phrases +: got-negaddr ( -- negotiate? ) ipcp-got >neg_addr c@ ; +: got-oldaddrs ( -- oldaddrs? ) ipcp-got >old_addrs c@ ; +: got-negvj ( -- negvj? ) ipcp-got >neg_vj c@ ; +: got-oldvj ( -- oldvj? ) ipcp-got >old_vj c@ ; +: got-local ( -- acc-local? ) ipcp-got >accept_local c@ ; +: got-remote ( -- acc-remote? ) ipcp-got >accept_remote c@ ; + +: allow-negaddr ( -- negotiate? ) ipcp-allow >neg_addr c@ ; + +: set-negaddr ( opts -- ) true swap >neg_addr c! ; +: clr-negaddr ( opts -- ) false swap >neg_addr c! ; +: set-oldaddr ( opts -- ) true swap >old_addrs c! ; +: clr-oldaddr ( opts -- ) false swap >old_addrs c! ; +: set-negvj ( opts -- ) true swap >neg_vj c! ; +: clr-negvj ( opts -- ) false swap >neg_vj c! ; +: set-oldvj ( opts -- ) true swap >old_vj c! ; +: clr-oldvj ( opts -- ) false swap >old_vj c! ; + +: ciaddrlen ( -- n ) + got-oldaddrs if CILEN_ADDRS else CILEN_ADDR then +; +: ciaddr ( -- n ) + got-oldaddrs if CI_ADDRS else CI_ADDR then +; +: civjlen ( -- n ) + got-oldvj if CILEN_COMPRESS else CILEN_VJ then +; + + +\ IP addresses + +4 constant /i \ Bytes per IP address +create unknown-ip-addr h# 00 c, h# 00 c, h# 00 c, h# 00 c, +: getip ( a1 -- a2 'ip ) /i gets ; +: putip ( a1 'ip -- a2 ) /i puts ; +: ip! ( src dst -- ) /i move ; +: ip= ( ip-addr1 ip-addr2 -- flag ) /i comp 0= ; +: ip<> ( ip-addr1 ip-addr2 -- flag ) ip= 0= ; +: ip0= ( adr-buf -- flag ) unknown-ip-addr ip= ; +: ip0<> ( adr-buf -- flag ) unknown-ip-addr ip<> ; + +: set-ouraddr ( ipaddr config -- ) >ouraddr ip! ; + +\ print a network IP address. +: dec-byte ( n -- ) u#s ascii . hold drop ; +: .ip ( buf -- ) + push-decimal ( buf ) + <# dup /i + 1- do i c@ dec-byte -1 +loop 0 u#> 1 /string ( adr len ) + pop-base + type space +; + +\ Input IPCP packet. +: ipcp_input ( a n -- ) ipcp-fsm fsm_input ; + +\ A Protocol-Reject was received for IPCP. +\ Pretend the lower layer went down, so we shut up. +: ipcp_protrej ( -- ) ipcp-fsm fsm_lowerdown ; + +\ Reset our CI. +: ipcp_resetci ( -- ) + ipcp-want ( wo ) + dup >neg_addr c@ allow-negaddr and + over >req_addr c! + dup >ouraddr ip0= if + true over >accept_local c! + then + dup >hisaddr ip0= if + true over >accept_remote c! + then ( wo ) + ipcp-got /ipcp move + + 0 to cis_received +; + +\ Return length of our CI. +: ipcp_cilen ( -- cilen ) + got-negaddr if ciaddrlen else 0 then + got-negvj if civjlen + then + ipcp-got >neg_dns c@ if CILEN_ADDR + then +; + +\ Add our desired CIs to a packet. +: ipcp_addci ( a n -- left-over ) + \ First see if we want to change our options to the old + \ forms because we have received old forms from the peer. + ipcp-want >neg_addr c@ + got-negaddr 0= and + got-oldaddrs 0= and if + \ use the old style of address negotiation + ipcp-got set-negaddr + ipcp-got set-oldaddr + then + ipcp-want >neg_vj c@ + got-negvj 0= and + got-oldvj 0= and if + \ try an older style of VJ negotiation + cis_received if + \ use the old style only if the peer did + ipcp-his >neg_vj c@ + ipcp-his >old_vj c@ and if + ipcp-got set-negvj + ipcp-got set-oldvj + ipcp-his >vj_protocol w@ ipcp-got >vj_protocol w! + then + else + \ keep trying the new style until we see some CI from the peer + ipcp-got set-negvj + then + then ( a n ) + + got-negaddr if + ciaddrlen 2dup >= if ( a n addrlen ) + rot ( n addrlen a ) + ciaddr putc over putc ( n addrlen a ) + ipcp-got >ouraddr putip + got-oldaddrs if + ipcp-got >hisaddr putip + then + -rot - ( a n ) + else ( a n addrlen ) + drop + ipcp-got clr-negaddr + then + then ( a n ) + + got-negvj if + civjlen 2dup >= if ( a n vjlen ) + rot ( n vjlen a ) + CI_COMPRESSTYPE putc over putc + ipcp-got >vj_protocol w@ putw + got-oldvj 0= if + ipcp-got >maxslotindex c@ putc + ipcp-got >cflag c@ putc + then + -rot - ( a n ) + else + drop + ipcp-got clr-negvj + then + then ( a n ) + ipcp-got >neg_dns c@ if + CILEN_ADDR 2dup >= if ( a n dnslen ) + rot ( n dnslen a ) + CI_MS_DNS1 putc over putc ( n dnslen a ) + ipcp-got >dnsaddr0 putip ( n dnslen a ) + -rot - ( a n ) + else + drop + false ipcp-got >neg_dns c! + then + then + nip +; + +: badack ( -- false ) + \ ." ipcp_ackci got bad Ack!" cr + false +; +\ Ack our CIs. +: ipcp_ackci ( a n -- okay? ) + \ CIs must be in exactly the same order that we sent... + \ Check packet length and CI length at each step. + \ If we find any deviations, then this packet is bad. + + got-negaddr if + ciaddrlen dup >r - dup 0< if + r> 3drop badack exit + then ( a n ) + + swap getc swap getc ( n citype a cilen ) + r> <> rot ciaddr <> or if + 2drop badack exit + then ( n a ) + + getip ipcp-got >ouraddr ip<> if ( n a ) + 2drop badack exit + then ( n a ) + + got-oldaddrs if ( n a ) + getip ipcp-got >hisaddr ip<> if ( n a ) + 2drop badack exit + then + then + swap ( a n ) + then + + got-negvj if + civjlen dup >r - dup 0< if + r> 3drop badack exit + then + + swap getc swap getc ( n citype a cilen ) + r> <> rot CI_COMPRESSTYPE <> or if + 2drop badack exit + then + + getw ipcp-got >vj_protocol w@ <> if + 2drop badack exit + then + + got-oldvj 0= if + getc ipcp-got >maxslotindex c@ <> if + 2drop badack exit + then + + getc ipcp-got >cflag c@ <> if + 2drop badack exit + then + then + swap + then ( a n ) + + ipcp-got >neg_dns c@ if + CILEN_ADDR dup >r - dup 0< if + r> 3drop badack exit + then ( a n ) + + swap getc swap getc ( n citype a cilen ) + r> <> rot CI_MS_DNS1 <> or if + 2drop badack exit + then ( n a ) + + getip ipcp-got >dnsaddr0 ip<> if ( n a ) + 2drop badack exit + then + swap ( a n ) + then + + \ If there are any remaining CIs, then this packet is bad. + nip if + badack exit + then + true +; + +: badnak ( -- false ) + \ ." ipcp_nakci got bad Nak!" cr + false +; +\ Peer has sent a NAK for some of our CIs. +\ This should not modify any state if the Nak is bad +\ or if IPCP is in the OPENED state. +: ipcp_nakci ( a n -- okay? ) + ipcp-nope /ipcp erase + ipcp-got ipcp-try /ipcp move + + \ Any Nak'd CIs must be in exactly the same order that we sent. + \ Check packet length and CI length at each step. + \ If we find any deviations, then this packet is bad. + + \ Accept the peer's idea of {our,his} address, if different + \ from our idea, only if the accept_{local,remote} flag is set. + got-negaddr if + ciaddrlen >r ( a n) + over 1+ c@ r@ = over r@ >= and if ( a n) + over c@ ciaddr = if + r@ - + swap 2+ getip swap ( n 'cip1 a ) + got-oldaddrs if ( n 'cip1 a ) + getip ( n 'cip1 a 'cip2 ) + ipcp-nope set-oldaddr ( n 'cip1 a 'cip2 ) + else ( n 'cip1 a ) + unknown-ip-addr ( n 'cip1 a 'cip2 ) + then ( n 'cip1 a 'cip2 ) + ipcp-nope set-negaddr + rot dup ip0<> got-local and if ( n a '2 '1 ) + \ We know our address + \ ." local IP address is " dup .ip cr + ipcp-try set-ouraddr ( n a 'cip2 ) + else ( n a '2 '1 ) + drop ( n a 'cip2 ) + then ( n a 'cip2 ) + dup ip0<> got-remote and if ( n a 'cip2 ) + \ He knows his address + \ ." remote IP address is " dup .ip cr + ipcp-try >hisaddr ip! ( n a ) + else ( n a 'cip2 ) + drop ( n a ) + then ( n a ) + swap ( a n ) + then ( a n ) + then ( a n ) + r> drop ( a n ) + then ( a n ) + + \ Accept the peer's value of maxslotindex provided that it + \ is less than what we asked for. Turn off slot-ID compression + \ if the peer wants. Send old-style compress-type option if + \ the peer wants. + got-negvj if + over 1+ c@ >r + over c@ CI_COMPRESSTYPE = + r@ CILEN_COMPRESS = r@ CILEN_VJ = or and ( a n flag ) + over r@ >= and if + ipcp-nope set-negvj + r@ - swap 2+ getw ( n a cishort ) + r@ CILEN_VJ = if + dup IPCP_VJ_COMP = if + drop ( n a ) + ipcp-try clr-oldvj + getc swap getc ( n a cimaxslotindex cicflag ) + 0= if + false ipcp-try >cflag c! + then ( n a cimaxslotindex ) + dup ipcp-got >maxslotindex c@ < if + ipcp-try >maxslotindex c! + else + drop 2+ + ipcp-try clr-negvj + then + else ( n a cishort ) + dup IPCP_VJ_COMP = over IPCP_VJ_COMP_OLD = or if + ipcp-try set-oldvj + ipcp-try >vj_protocol w! + else + drop + ipcp-try clr-negvj + then + then + then + swap ( a n ) + then + r> drop + then ( a n ) + + ipcp-got >neg_dns c@ if + CILEN_ADDR >r ( a n ) + over 1+ c@ r@ = over r@ >= and if ( a n ) + over c@ CI_MS_DNS1 = if + r@ - + swap 2+ getip swap ( n 'cip1 a ) + swap dup ip0<> if ( n a '1 ) + ipcp-try >dnsaddr0 ip! ( n a ) + else ( n a '1 ) + drop ( n a ) + then ( n a ) + swap ( a n ) + then ( a n ) + then ( a n ) + r> drop ( a n ) + then + + \ There may be remaining CIs, if the peer is requesting negotiation + \ on an option that we didn't include in our request packet. + \ If they want to negotiate about IP addresses, we comply. + \ If they want us to ask for compression, we refuse. + begin dup CILEN_VOID > while + over >r over c@ -rot over 1+ c@ >r ( citype a n ) ( r: a cilen ) + r@ /string dup 0< if + 2r> 5drop badnak exit + then + + rot case + CI_COMPRESSTYPE of ( a n ) + got-negvj ipcp-nope >neg_vj c@ or + r@ CILEN_VJ <> r@ CILEN_COMPRESS <> and or if + 2r> 4drop badnak exit + then + + ipcp-nope set-negvj + endof + CI_ADDRS of ( a n ) + got-negaddr got-oldaddrs and + ipcp-nope >old_addrs c@ or + r@ CILEN_ADDRS <> or if + 2r> 4drop badnak exit + then + + ipcp-try set-negaddr + ipcp-try set-oldaddr + swap getip ( n a 'cip1 ) + dup ip0<> got-local and if ( n a 'cip1 ) + \ ." got local IP address " dup .ip cr + ipcp-try set-ouraddr + else + drop + then + getip ( n a 'cip2 ) + dup ip0<> got-remote and if + ipcp-try >hisaddr ip! + else + drop + then + ipcp-nope set-oldaddr + swap + endof + CI_ADDR of ( a n ) + got-negaddr ipcp-nope >neg_addr c@ or CILEN_ADDR r@ <> or if + 2r> 4drop badnak exit + then + + ipcp-try clr-oldaddr + swap getip ( n a 'cip1 ) + dup ip0<> got-local and if + \ ." received local IP address " dup .ip cr + ipcp-try set-ouraddr + else + drop + then + swap + ipcp-try >ouraddr ip0<> if + ipcp-try set-negaddr + then + ipcp-nope set-negaddr + endof + endcase + nip 2r> + swap ( a n ) ( r: ) + repeat + + \ If there is still anything left, this packet is bad. + nip if badnak exit then + + \ OK, the Nak is good. Now we can update state. + ipcp-fsm >f_state c@ OPENED <> if + ipcp-try ipcp-got /ipcp move + then + true +; + +: badrej ( -- false ) + \ ." ipcp_rejci got bad Reject!" cr + false +; +\ Reject some of our CIs. +: ipcp_rejci ( a n -- okay? ) + ipcp-got ipcp-try /ipcp move ( a n ) + + \ Any Rejected CIs must be in exactly the same order that we sent. + \ Check packet length and CI length at each step. + \ If we find any deviations, then this packet is bad. + got-negaddr if ( a n ) + ciaddrlen >r + swap getc ciaddr = + swap getc r@ = rot and ( n a flag ) + rot dup r@ >= rot and if ( a n ) + r@ - swap getip ( n a 'ip ) + \ Check rejected value. + ipcp-got >ouraddr ip<> if ( n a ) + r> 3drop badrej exit + then ( n a ) + + got-oldaddrs if + getip ( n a 'ip ) + \ Check rejected value. + ipcp-got >hisaddr ip<> if + r> 3drop badrej exit + then ( n a ) + then + + swap + ipcp-try clr-negaddr + else + swap 2- swap + then ( a n ) + r> drop + then ( a n ) + + got-negvj if ( a n ) + civjlen >r + over dup c@ CI_COMPRESSTYPE = swap 1+ c@ r@ = and over r@ >= and if + r> - swap 2+ getw ( n a cishort ) + \ Check rejected value. \ + ipcp-got >vj_protocol w@ <> if + 2drop badrej exit + then ( n a ) + + got-oldvj 0= if + getc ipcp-got >maxslotindex c@ <> if + 2drop badrej exit + then + + getc ipcp-got >cflag c@ <> if + 2drop badrej exit + then + then + + swap ( a n ) + ipcp-try clr-negvj + else + r> drop + then + then ( a n ) + + ipcp-got >neg_dns if ( a n ) + CILEN_ADDR >r + swap getc CI_MS_DNS1 = + swap getc r@ = rot and ( n a flag ) + rot dup r@ >= rot and if ( a n ) + r@ - swap getip ( n a 'ip ) + \ Check rejected value. + ipcp-got >dnsaddr0 ip<> if ( n a ) + r> 3drop badrej exit + then ( n a ) + swap + false ipcp-try >neg_dns c! + then ( a n ) + r> drop + then ( a n ) + nip + + \ If there are any remaining CIs, then this packet is bad. + if badrej exit then + + \ Now we can update state. + ipcp-fsm >f_state c@ OPENED <> if + ipcp-try ipcp-got /ipcp move + then + true +; +: ipcp-reqci-addrs ( a cilen -- result ) + CILEN_ADDRS <> allow-negaddr 0= or if ( a ) + drop CONFREJ exit + then ( a ) + + \ If he has no address, or if we both have his address but + \ disagree about it, then NAK it with our idea. + \ In particular, if we don't know his address, but he does, + \ then accept it. + getip ( a 'cip ) + dup ipcp-want >hisaddr ip<> + over ip0= ipcp-want >accept_remote c@ 0= or + and if ( a 'cip1 ) + drop ( a ) + reject_if_disagree 0= if ( a ) + ipcp-want >hisaddr over /l - ip! ( a ) + then + drop CONFNAK exit + then ( a 'cip1 ) + + dup ip0= ipcp-want >hisaddr ip0= and if ( a 'cip1 ) + \ If neither we nor he knows his address, reject the option. + 2drop ( ) + false ipcp-want >req_addr c! + CONFREJ exit + then ( a 'cip1 ) + + ipcp-his >hisaddr ip! ( a ) + \ If he doesn't know our address, or if we both have our + \ address but disagree about it, then NAK it with our idea. + \ Parse desination address (ours) + getip ( a 'cip2 ) + \ ." he says our address is " dup .ip cr + dup ipcp-his set-ouraddr ( a 'cip2 ) + dup ipcp-want >ouraddr ip<> if ( a 'cip2 ) + dup ip0= ipcp-want >accept_local c@ 0= or if ( a 'cip2 ) + drop + reject_if_disagree 0= if ( a ) + ipcp-want >ouraddr over /l - ip! + then ( a ) + drop CONFNAK ( result ) + else ( a 'cip2 ) + \ ." accept peer's idea " cr + ipcp-got set-ouraddr ( a ) + drop CONFACK + then ( result ) + else ( a 'cip2 ) + 2drop CONFACK + then ( result ) + ipcp-his set-negaddr + ipcp-his set-oldaddr +; +: ipcp-reqci-addr ( a cilen -- result ) + CILEN_ADDR <> allow-negaddr 0= or if ( a ) + drop CONFREJ exit + then ( a ) + + \ If he has no address, or if we both have his address but + \ disagree about it, then NAK it with our idea. + \ In particular, if we don't know his address, but he does, + \ then accept it. + getip ( a 'cip1 ) + dup ipcp-want >hisaddr ip<> + over ip0= ipcp-want >accept_remote c@ 0= or + and if ( a 'cip1 ) + drop ( a ) + reject_if_disagree 0= if + ipcp-want >hisaddr over /l - ip! + then + drop CONFNAK exit + then ( a 'cip1 ) + + dup ip0= ipcp-want >hisaddr ip0= and if ( a 'cip1 ) + \ If neither we nor he knows his address, reject the option. + 2drop ( ) + false ipcp-want >req_addr c! + CONFREJ + else ( a 'cip1 ) + ipcp-his >hisaddr ip! ( a ) + ipcp-his set-negaddr ( a ) + drop CONFACK + then +; +: ipcp-reqci-comp ( a cilen -- result ) + dup CILEN_VJ <> over CILEN_COMPRESS <> and + ipcp-allow >neg_vj c@ 0= or if ( a cilen ) + 2drop CONFREJ exit + then ( a cilen ) + + swap getw ( cilen a cishort ) + 2 pick CILEN_COMPRESS = over IPCP_VJ_COMP_OLD = and + over IPCP_VJ_COMP = or 0= if ( cilen a cishort ) + 3drop CONFREJ exit ( result ) + then ( cilen a cishort ) + + ipcp-his set-negvj + ipcp-his >vj_protocol w! ( cilen a ) + swap CILEN_VJ = if ( a ) + getc ( a maxslotindex ) + dup ipcp-his >maxslotindex c! + ipcp-allow >maxslotindex c@ > if ( a ) + reject_if_disagree 0= if + ipcp-allow >maxslotindex c@ over 1- c! + then + CONFNAK + else ( a ) + CONFACK + then ( a result ) + swap getc ( result a cflag ) + dup ipcp-his >cflag c! + ipcp-allow >cflag c@ 0= and if ( result a ) + nip CONFNAK swap + reject_if_disagree 0= if + ipcp-want >cflag c@ over 1- c! + then + then ( result a ) + drop + else ( a ) + ipcp-his set-oldvj + 1 ipcp-his >cflag c! + MAX_STATES 1- ipcp-his >maxslotindex c! + drop CONFACK + then +; +: ipcp-reqci-dns1 ( a cilen -- result ) + \ If we do not have a DNS address then we cannot send it + CILEN_ADDR <> ipcp-want >dnsaddr0 ip0= or if ( a ) + drop CONFREJ + else ( a ) + dup ipcp-want >dnsaddr0 ip= if ( a ) + drop CONFACK + else ( a ) + ipcp-want >dnsaddr0 swap ip! ( ) + CONFNAK + then + then +; +: ipcp-reqci-dns2 ( a cilen -- result ) + \ If we do not have a DNS address then we cannot send it + CILEN_ADDR <> ipcp-want >dnsaddr0 ip0= or if ( a ) + drop CONFREJ + else ( a ) + dup ipcp-want >dnsaddr1 ip= if ( a ) + drop CONFACK + else + ipcp-want >dnsaddr1 swap ip! ( ) + CONFNAK + then + then +; +: ipcp-reqci-sw ( a cilen citype -- result ) + case + CI_ADDRS of ( a cilen ) + ipcp-reqci-addrs ( result ) + endof + CI_ADDR of ( a cilen ) + ipcp-reqci-addr ( result ) + endof + CI_COMPRESSTYPE of ( a cilen ) + ipcp-reqci-comp ( result ) + endof + CI_MS_DNS1 of \ Microsoft DNS ( a cilen ) + ipcp-reqci-dns1 + endof + CI_MS_DNS2 of ( a cilen ) + ipcp-reqci-dns2 + endof + ( default ) + >r ( a cilen ) + \ ." ipcp_reqci got unknown option " r@ . cr + 2drop CONFREJ + r> + endcase ( a result ) +; +0 value ucp +: ipcp-reqci-status ( a n next status result -- a n next result ) + >r + dup CONFACK = r@ CONFACK <> and 0= if ( a n next status ) + dup CONFNAK = reject_if_disagree 0= and r@ CONFREJ = and 0= if + dup CONFNAK = if + reject_if_disagree if + drop CONFREJ + else ( a n next status ) + r@ CONFACK = if + r> drop CONFNAK >r + 3 pick to ucp \ backup \ XXX should this be r@ to ucp ??? + then + then + then ( a n next status ) + dup CONFREJ = r@ CONFREJ <> and if ( a n next status ) + r> drop CONFREJ >r + 3 pick to ucp \ backup + then ( a n next status ) + ucp cip <> if + cip ucp over 1+ c@ move + then + cip 1+ c@ ucp + to ucp + then + then ( a n next status ) + drop r> +; +: ipcp-reqci-finish ( a result -- n okay? ) + \ If we aren't rejecting this packet, and we want to negotiate + \ their address, and they didn't send their address, then we + \ send a NAK with a CI_ADDR option appended. We assume the + \ input buffer is long enough that we can append the extra + \ option safely. + >r + r@ CONFREJ <> ipcp-his >neg_addr c@ 0= and + ipcp-want >req_addr c@ and reject_if_disagree 0= and if + r@ CONFACK = if + r> drop CONFNAK >r + dup to ucp \ reset pointer + false ipcp-want >req_addr c! \ don't ask again + then + ucp CI_ADDR putc CILEN_ADDR putc ipcp-want >hisaddr putip + to ucp + then + ucp swap - \ Compute output length + r> \ Return final code +; +\ Check the peer's requested CIs and send appropriate response. +\ Returns of CONFACK, CONFNAK or CONFREJ and input packet modified +\ appropriately. If reject_if_disagree is non-zero, doesn't return +\ CONFNAK; returns CONFREJ if it can't return CONFACK. +: ipcp_reqci ( a n1 reject_if_disagree -- n2 okay? ) + to reject_if_disagree + over to ucp + CONFACK >r \ Final packet return code + + \ Reset all his options. + ipcp-his /ipcp erase + + \ Process all his options. + over ( a n next ) + begin over while ( a n next ) + dup to cip + 2dup 1+ c@ 2 rot between 0= ( a n next bad? ) + 2 pick 2 < or if \ Reject till end of packet + \ ." ipcp_reqci got bad CI length! " cr ( a n next ) + nip 0 swap \ Don't loop again + CONFREJ ( a n next status ) + else ( a n next ) + dup >r + tuck 1+ c@ /string swap ( a n next' ) + r> getc swap getc rot ( a n next' next cilen citype ) + ipcp-reqci-sw ( a n next' status ) + then + r> ipcp-reqci-status >r ( a n next' ) + repeat ( a n next ) + 2drop ( a ) + r> ipcp-reqci-finish +; + +\ IPCP has come UP. +\ Configure the IP network interface appropriately and bring it up. +: ipcp_up ( -- ) + show-states? if cr then + + \ We must have a non-zero IP address for both ends of the link. + ipcp-his >neg_addr c@ 0= if + ipcp-want >hisaddr ipcp-his >hisaddr ip! + then + ipcp-his >hisaddr ip0= if + ." Could not determine remote IP address" cr + ipcp-fsm fsm_close + exit + then + + ipcp-got >ouraddr ip0= if + ." Could not determine local IP address" cr + ipcp-fsm fsm_close + exit + then + +\ ." local IP address " ipcp-got >ouraddr .ip cr +\ ." remote IP address " ipcp-his >hisaddr .ip cr + true to ppp-is-open +; + + +\ IPCP has gone DOWN. +\ Take the IP network interface down, clear its addresses +\ and delete routes through it. +: ipcp_down ( -- ) false to ppp-is-open ; + +: ipcp_extcode ( a n code id -- handled? ) 4drop false ; + +create ipcp-callbacks + ] + ipcp_resetci ipcp_cilen ipcp_addci ipcp_ackci ipcp_nakci ipcp_rejci ipcp_reqci + ipcp_up ipcp_down noop ipcp_protrej ipcp_extcode + [ + +\ Initialize IPCP. +: ipcp_init ( -- ) + ipcp-fsm + PPP_IPCP over >protocol ! + ipcp-callbacks over >callbacks /fsm_callbacks move + fsm_init + + ipcp-want /ipcp erase + ipcp-want set-negaddr + true ipcp-want >neg_dns c! + \ ipcp-want + \ dup set-negvj + \ IPCP_VJ_COMP over >vj_protocol w! + \ MAX_STATES 1- over >maxslotindex c! + \ 1 over >cflag c! + \ drop + + \ max slots and slot-id compression are currently hardwired to 16 and 1 + ipcp-allow /ipcp erase + ipcp-allow set-negaddr + true ipcp-allow >neg_dns c! + \ ipcp-allow + \ dup set-negvj + \ MAX_STATES 1- over >maxslotindex c! + \ 1 over >cflag c! + \ drop +; + +external +: point-to-point? ( -- 'his-ip 'my-ip true ) + ipcp-his >hisaddr ipcp-got >ouraddr true +; +[ifdef] use-auto-dns +: dns-servers ( -- false | 'dns-ip1 'dns-ip0 true ) + ipcp-got >dnsaddr0 ip0= if + ipcp-got >dnsaddr1 ip0= if false exit then + + unknown-ip-addr ipcp-got >dnsaddr1 true exit + then + + ipcp-got >dnsaddr1 ip0= if + unknown-ip-addr + else + ipcp-got >dnsaddr1 + then + ipcp-got >dnsaddr0 true +; +[else] +: ?bad-ip ( flag -- ) abort" Bad host name or address" ; +: $>ip ( adr len buf -- ) + push-decimal + 4 bounds do + [char] . left-parse-string $number ?bad-ip + dup d# 256 >= ?bad-ip + i c! + loop + pop-base + 2drop +; + +: ip-or-unknown ( name$ buf -- 'ip ) + >r $ppp-info dup 0= if ( name$ r: buf ) + r> 3drop unknown-ip-addr ( 'ip ) + else ( name$ r: buf ) + r@ $>ip r> ( 'ip ) + then +; +8 buffer: ip-buf +: dns-servers ( -- 'dns-ip1 'dns-ip0 true ) + " dns-server1" ip-buf 4 + ip-or-unknown + " dns-server0" ip-buf ip-or-unknown + dup ip0= if swap then + dup ip0= if 2drop false else true then +; +[then] +: domain-name ( -- name$ ) " domain-name" $ppp-info ; + +headers +\ LICENSE_BEGIN +\ Copyright (c) 2006 FirmWorks +\ +\ Permission is hereby granted, free of charge, to any person obtaining +\ a copy of this software and associated documentation files (the +\ "Software"), to deal in the Software without restriction, including +\ without limitation the rights to use, copy, modify, merge, publish, +\ distribute, sublicense, and/or sell copies of the Software, and to +\ permit persons to whom the Software is furnished to do so, subject to +\ the following conditions: +\ +\ The above copyright notice and this permission notice shall be +\ included in all copies or substantial portions of the Software. +\ +\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +\ +\ LICENSE_END diff --git a/src/ofw/ppp/lcp.fth b/src/ofw/ppp/lcp.fth new file mode 100644 index 0000000..ae7f5e5 --- /dev/null +++ b/src/ofw/ppp/lcp.fth @@ -0,0 +1,1294 @@ +\ See license at end of file +purpose: LCP -- PPP Link Control Protocol + +decimal + +\ Options. +1 constant CI_MRU \ Maximum Receive Unit +2 constant CI_ASYNCMAP \ Async Control Character Map +3 constant CI_AUTHTYPE \ Authentication Type +4 constant CI_QUALITY \ Quality Protocol +5 constant CI_MAGICNUMBER \ Magic Number +7 constant CI_PCOMPRESSION \ Protocol Field Compression +8 constant CI_ACCOMPRESSION \ Address/Control Field Compression + +\ LCP-specific packet types. +8 constant PROTREJ \ Protocol Reject +9 constant ECHOREQ \ Echo Request +10 constant ECHOREP \ Echo Reply +11 constant DISCREQ \ Discard Request + +\ Lengths of configuration options. +4 constant CILEN_SHORT +6 constant CILEN_LONG +5 constant CILEN_CHAP +8 constant CILEN_LQR + +\ LCP options +struct + 4 field >asyncmap \ Value of async map + 4 field >magicnumber + 4 field >numloops \ Number of loops during magic number neg. + 4 field >lqr_period \ Reporting period for LQR 1/100ths second + + 2 field >mru \ Value of MRU + 1 field >neg_mru \ Negotiate the MRU? + 1 field >neg_asyncmap \ Negotiate the async map? + + 1 field >neg_upap \ Ask for UPAP authentication? + 1 field >neg_chap \ Ask for CHAP authentication? + 1 field >neg_magicnumber \ Ask for magic number? + 1 field >neg_pcompression \ HDLC Protocol Field >Compression? + + 1 field >neg_accompression \ HDLC Address/Control Field >Compression? + 1 field >neg_lqr \ Negotiate use of Link Quality Reports + 1 field >chap_mdtype \ which MD type (hashing algorithm) + 1+ +constant /lcp + +/lcp buffer: lcp-want +/lcp buffer: lcp-allow +/lcp buffer: lcp-got +/lcp buffer: lcp-his +/lcp buffer: lcp-nope \ options we've seen Naks for +/lcp buffer: lcp-try \ options to request next time + +32 buffer: xmit_accm \ extended transmit ACCM +PPP_MRU buffer: nak_buffer \ where we construct a nak packet + +0 value lcp_echos_pending \ Number of outstanding echo msgs +0 value lcp_echo_number \ ID number of next echo frame +0 value lcp_echo_timer_running \ TRUE if a timer is running +0 value lcp_echo_interval \ Interval between LCP echo-requests +0 value lcp_echo_fails \ Tolerance to unanswered echo-requests + +0 value looped_back + +DEFLOOPBACKFAIL value lcp_loopbackfail + +variable nakp 0 nakp ! +variable rejp 0 rejp ! + +: put-nakp-char ( -- ) nakp putchar ; +: put-nakp-short ( -- ) nakp putshort ; +: put-nakp-long ( -- ) nakp putlong ; + +: lcp-state ( -- n ) lcp-fsm >f_state c@ ; + +\ LCP is allowed to come up. +: lcp_open ( -- ) lcp-fsm fsm_open ; + +\ Take LCP down. +: lcp_close ( -- ) lcp-fsm fsm_close ; + +\ Callbacks + +\ Reset our Configuration Info. +: lcp_resetci ( -- ) + magic lcp-want >magicnumber ! + 0 lcp-want >numloops ! + lcp-want lcp-got /lcp move + PPP_MRU to peer_mru +; + +\ Return length of our CI. +: ?lencivoid ( n1 neg -- n2 ) c@ if CILEN_VOID + then ; +: ?lencichap ( n1 neg -- n2 ) c@ if CILEN_CHAP + then ; +: ?lencishort ( n1 neg -- n2 ) c@ if CILEN_SHORT + then ; +: ?lencilong ( n1 neg -- n2 ) c@ if CILEN_LONG + then ; +: ?lencilqr ( n1 neg -- n2 ) c@ if CILEN_LQR + then ; +: lcp_cilen ( -- cilen ) + lcp-got >r + 0 + r@ >neg_mru ?lencishort + r@ >neg_asyncmap ?lencilong + r@ >neg_chap ?lencichap + \ Only ask for one of CHAP and UPAP, even if we will accept either. + r@ >neg_chap c@ 0= if + r@ >neg_upap ?lencishort + then + r@ >neg_lqr ?lencilqr + r@ >neg_magicnumber ?lencilong + r@ >neg_pcompression ?lencivoid + r> >neg_accompression ?lencivoid +; + +: rot-swap-putc ( a1 val opt -- val a2 ) rot swap putc ; + +\ Add our desired CIs to a packet. +: addcivoid ( a1 opt neg -- a2 ) + c@ if + putc CILEN_VOID putc + else + drop + then +; +: addcishort ( a1 val opt neg -- a2 ) + c@ if + rot-swap-putc CILEN_SHORT putc swap putw + else + 2drop + then +; +: addcilong ( a1 val opt neg -- a2 ) + c@ if + rot-swap-putc CILEN_LONG putc swap putl + else + 2drop + then +; +: addcilqr ( a1 val opt neg -- a2 ) + c@ if + rot-swap-putc CILEN_LQR putc PPP_LQR putw swap putl + else + 2drop + then +; +: addcichap ( a1 val opt neg -- a2 ) + c@ if + rot-swap-putc CILEN_CHAP putc PPP_CHAP putw swap putc + else + 2drop + then +; + +: lcp_addci ( a n -- left-over ) + lcp-got >r + over ( a n a1 ) + r@ >mru w@ CI_MRU r@ >neg_mru addcishort + r@ >asyncmap l@ CI_ASYNCMAP r@ >neg_asyncmap addcilong + r@ >chap_mdtype c@ CI_AUTHTYPE r@ >neg_chap addcichap + r@ >neg_chap c@ 0= if + PPP_PAP CI_AUTHTYPE r@ >neg_upap addcishort + then + r@ >lqr_period l@ CI_QUALITY r@ >neg_lqr addcilqr + r@ >magicnumber l@ CI_MAGICNUMBER r@ >neg_magicnumber addcilong + CI_PCOMPRESSION r@ >neg_pcompression addcivoid + CI_ACCOMPRESSION r> >neg_accompression addcivoid + ( a n a1 ) + rot - - +; +: ackcivoid ( a1 n1 opt neg -- a2 n2 error? ) + c@ if ( a1 n1 opt ) + -rot CILEN_VOID - dup 0< if rot drop true exit then ( opt a n ) + -rot getc rot <> ( n a err ) + swap getc CILEN_VOID <> rot or + rot swap ( a n err ) + else ( a1 n1 opt ) + drop false ( a n err ) + then ( a2 n2 err ) +; +: ackcishort ( a1 n1 val opt neg -- a2 n2 error? ) + c@ if + 2swap CILEN_SHORT - dup 0< if + 2nip true exit + then ( val opt a n ) + >r getc rot <> swap ( val err a ) + getc CILEN_SHORT <> rot or ( val a err ) + -rot getw rot <> rot or ( a err ) + r> swap + else + 2drop false + then +; +: ackcilong ( a1 n1 val opt neg -- a2 n2 error? ) + c@ if + 2swap CILEN_LONG - dup 0< if + 2nip true exit + then ( val opt a n ) + >r getc rot <> swap ( val err a ) + getc CILEN_LONG <> rot or ( val a err ) + -rot getl rot <> rot or ( a err ) + r> swap + else + 2drop false + then +; +: ackcilqr ( a1 n1 val opt neg -- a2 n2 error? ) + c@ if + 2swap CILEN_LQR - dup 0< if + 2nip true exit + then ( val opt a n ) + >r getc rot <> swap ( val err a ) + getc CILEN_LQR <> rot or ( val a err ) + -rot getw PPP_LQR <> rot or ( val a err ) + -rot getl rot <> rot or ( a err ) + r> swap + else + 2drop false + then +; +: ackcichap ( a1 n1 digest opt neg -- a2 n2 error? ) + c@ if + >r 2swap r> -rot ( digest opt a1 n1 ) + CILEN_CHAP - dup 0< if + 2nip true exit + then + >r getc rot <> swap ( digest err a ) + getc CILEN_CHAP <> rot or ( digest a err ) + swap getw PPP_CHAP <> rot or ( digest a err ) + -rot getc rot <> rot or ( a err ) + r> swap + else + 2drop false + then +; +\ Ack our CIs. +\ This should not modify any state if the Ack is bad. +: lcp_ackci ( a n -- good? ) + lcp-got >r + + \ CIs must be in exactly the same order that we sent. + \ Check packet length and CI length at each step. + \ If we find any deviations, then this packet is bad. + CI_MRU r@ >mru w@ r@ >neg_mru ackcishort if r> 3drop false exit then + CI_ASYNCMAP r@ >asyncmap @ r@ >neg_asyncmap + ackcilong if r> 3drop false exit then + CI_AUTHTYPE r@ >chap_mdtype c@ r@ >neg_chap + ackcichap if r> 3drop false exit then + r@ >neg_chap c@ 0= if + CI_AUTHTYPE PPP_PAP r@ >neg_upap ackcishort if r> 3drop false exit then + then + CI_QUALITY r@ >lqr_period @ r@ >neg_lqr + ackcilqr if r> 3drop false exit then + r@ >magicnumber @ CI_MAGICNUMBER r@ >neg_magicnumber + ackcilong if r> 3drop false exit then + CI_PCOMPRESSION r@ >neg_pcompression ackcivoid if r> 3drop false exit then + CI_ACCOMPRESSION r@ >neg_accompression ackcivoid if r> 3drop false exit then + nip r> drop ( n ) + \ If there are any remaining CIs, then this packet is bad. + 0= +; +: nakcivoid? ( a n opt neg -- a n nak? ) + dup >r + lcp-got + c@ if + >r over be-w@ wbsplit r> = swap CILEN_VOID = and + over CILEN_VOID >= and if + CILEN_VOID /string + true lcp-nope r@ + c! + true + else + false + then + else + drop false + then + r> drop +; +: nakcishort? ( a n opt neg -- a n short nak? ) + dup >r + lcp-got + c@ if + >r over be-w@ wbsplit r> = swap CILEN_SHORT = and + over CILEN_SHORT >= and if + >r 2+ getw r> CILEN_SHORT - swap + true lcp-nope r@ + c! + true + else + 0 false + then + else + false + then + r> drop +; +: nakcilong? ( a n opt neg -- a n long nak? ) + dup >r + lcp-got + c@ if ( a n opt ) + >r over be-w@ wbsplit r> = swap CILEN_LONG = and + over CILEN_LONG >= and if ( a n ) + >r 2+ getl r> CILEN_LONG - swap ( a n long ) + true lcp-nope r@ + c! + true + else ( a n ) + 0 false + then + else ( a n opt ) + false + then + r> drop +; +: nakcilqr? ( a n opt neg -- a n short long nak? ) + dup >r + lcp-got + c@ if ( a n opt ) + >r over be-w@ wbsplit r> = swap CILEN_LQR = and + over CILEN_LQR >= and if ( a n ) + >r 2+ getw swap getl swap ( w l a ) + r> CILEN_LQR - 2swap ( a n w l ) + true lcp-nope r@ + c! + true + else ( a n ) + 0 0 false + then + else ( a n opt ) + 0 false + then + r> drop +; +: bad-nak ( -- ) + \ ." lcp_nakci received bad Nak!" cr +; +\ Peer has sent a NAK for some of our CIs. +\ This should not modify any state if the Nak is bad +\ or if LCP is in the OPENED state. +: lcp_nakci ( a n -- good? ) + lcp-nope /lcp erase + lcp-got lcp-try /lcp move + + \ Any Nak'd CIs must be in exactly the same order that we sent. + \ Check packet length and CI length at each step. + \ If we find any deviations, then this packet is bad. + + \ We don't care if they want to send us smaller packets than + \ we want. Therefore, accept any MRU less than what we asked for, + \ but then ignore the new value when setting the MRU in the kernel. + \ If they send us a bigger MRU than what we asked, accept it, up to + \ the limit of the default MRU we'd get if we didn't negotiate. + CI_MRU 0 >neg_mru nakcishort? if ( a n short ) + dup lcp-want >mru w@ <= over DEFMRU < or if + dup lcp-try >mru w! + then + then + drop + + \ Add any characters they want to our (receive-side) asyncmap. + CI_ASYNCMAP 0 >neg_asyncmap nakcilong? if ( a n long ) + dup lcp-try >asyncmap dup @ rot or swap ! ( a n long ) + then + drop ( a n ) + + \ If they've nak'd our authentication-protocol, check whether + \ they are proposing a different protocol, or a different + \ hash algorithm for CHAP. + lcp-got dup >neg_chap c@ swap >neg_upap c@ or if ( a n ) + >r ( a ) ( r: n ) + getc CI_AUTHTYPE = >r getc dup CILEN_SHORT >= r> and + r@ CILEN_SHORT >= and if ( a cilen ) ( r: n ) + swap getw rot swap ( a cilen short ) + over CILEN_SHORT = over PPP_PAP = and if ( a cilen short ) + 2drop ( a ) + \ If they are asking for PAP, then they don't want to do CHAP. + \ If we weren't asking for CHAP, then we were asking for PAP, + \ in which case this Nak is bad. + lcp-got >neg_chap c@ 0= if ( a ) ( r: n ) + bad-nak r> 2drop false exit + then + false lcp-got >neg_chap c! ( a ) + else ( a cilen short ) + over CILEN_CHAP = swap PPP_CHAP = and if ( a cilen ) + drop getc lcp-got >neg_chap c@ if ( a char ) + \ We were asking for CHAP/MD5; they must want a different + \ algorithm. If they can't do MD5, we'll have to stop + \ asking for CHAP. + lcp-got >chap_mdtype c@ <> if ( a ) + \ ." lcp_nakci got chap nak due to mdtype differences" cr + false lcp-got >neg_chap c! + then ( a ) + else ( a char ) + drop ( a ) + \ Stop asking for PAP if we were asking for it. + false lcp-got >neg_upap c! + then ( a ) + else ( a cilen ) + \ We don't recognize what they're suggesting. + \ Stop asking for what we were asking for. + lcp-got >neg_chap c@ if + false lcp-got >neg_chap c! + else + false lcp-got >neg_upap c! + then ( a cilen ) + + CILEN_SHORT - ( a' ) + then ( a ) + then ( a ) + then ( a ) + r> ( a n ) + then ( a n ) + + \ Peer shouldn't send Nak for protocol compression or + \ address/control compression requests; they should send + \ a Reject instead. If they send a Nak, treat it as a Reject. + lcp-got >neg_chap c@ 0= if + CI_AUTHTYPE 0 >neg_upap nakcishort? if ( a n short ) + 0 lcp-try >neg_upap c! + then + drop + then ( a n ) + + \ If they can't cope with our link quality protocol, we'll have + \ to stop asking for LQR. We haven't got any other protocol. + \ If they Nak the reporting period, take their value. XXX? + CI_QUALITY 0 >neg_lqr nakcilqr? if ( a n short long ) + over PPP_LQR <> if + false lcp-try >neg_lqr c! + else + dup lcp-try >lqr_period ! + then + then ( a n short long ) + 2drop ( a n ) + + \ Check for a looped-back line. + CI_MAGICNUMBER 0 >neg_magicnumber nakcilong? if + magic lcp-try >magicnumber ! + true to looped_back + then + drop + + CI_PCOMPRESSION 0 >neg_pcompression nakcivoid? if + false lcp-try >neg_pcompression c! + then + + CI_ACCOMPRESSION 0 >neg_accompression nakcivoid? if + false lcp-try >neg_accompression c! + then + + \ There may be remaining CIs, if the peer is requesting negotiation + \ on an option that we didn't include in our request packet. + \ If we see an option that we requested, or one we've already seen + \ in this packet, then this packet is bad. + \ If we wanted to respond by starting to negotiate on the requested + \ option(s), we could, but we don't, because except for the + \ authentication type and quality protocol, if we are not negotiating + \ an option, it is because we were told not to. + \ For the authentication type, the Nak from the peer means + \ `let me authenticate myself with you' which is a bit pointless. + \ For the quality protocol, the Nak means `ask me to send you quality + \ reports', but if we didn't ask for them, we don't want them. + \ An option we don't recognize represents the peer asking to + \ negotiate some option we don't support, so ignore it. + ( a n ) + begin ( a n ) + dup CILEN_VOID > + while + >r getc swap getc r> ( citype a cilen n ) + over - dup 0< if + bad-nak 4drop r> drop false exit + then + + >r tuck + 2- >r ( citype cilen ) + swap case + CI_MRU of + CILEN_SHORT <> lcp-got >neg_mru c@ or + lcp-nope >neg_mru c@ or if + bad-nak 2r> r> 3drop false exit + then + endof + CI_ASYNCMAP of + CILEN_LONG <> lcp-got >neg_asyncmap c@ or + lcp-nope >neg_asyncmap c@ or if + bad-nak 2r> r> 3drop false exit + then + endof + CI_AUTHTYPE of + drop lcp-got >neg_chap c@ lcp-nope >neg_chap c@ or + lcp-got >neg_upap c@ lcp-nope >neg_upap c@ or or if + bad-nak 2r> r> 3drop false exit + then + endof + CI_MAGICNUMBER of + CILEN_LONG <> lcp-got >neg_magicnumber c@ or + lcp-nope >neg_magicnumber c@ or if + bad-nak 2r> r> 3drop false exit + then + endof + CI_PCOMPRESSION of + CILEN_VOID <> lcp-got >neg_pcompression c@ or + lcp-nope >neg_pcompression c@ or if + bad-nak 2r> r> 3drop false exit + then + endof + CI_ACCOMPRESSION of + CILEN_VOID <> lcp-got >neg_accompression c@ or + lcp-nope >neg_accompression c@ or if + bad-nak 2r> r> 3drop false exit + then + endof + CI_QUALITY of + CILEN_LQR <> lcp-got >neg_lqr c@ or + lcp-nope >neg_lqr c@ or if + bad-nak 2r> r> 3drop false exit + then + endof + endcase + r> r> + repeat ( a n ) + + \ If there is still anything left, this packet is bad. + if + bad-nak r> 2drop false exit + then + drop + + \ OK, the Nak is good. Now we can update state. + lcp-state OPENED <> if + looped_back if + 1 lcp-try >numloops +! + lcp-try >numloops @ lcp_loopbackfail >= if + \ ." Serial line is looped back." cr + lcp_close + then + else + 0 lcp-try >numloops ! + lcp-try lcp-got /lcp move + then + then + true +; + +: rejcivoid ( a n opt neg -- a n ) + dup >r + lcp-got + c@ if ( a n opt ) + >r over be-w@ wbsplit r> = swap CILEN_VOID = and + over CILEN_VOID >= and if ( a n ) + CILEN_VOID /string + false lcp-try r@ + c! + then + else ( a n opt ) + drop + then + r> drop +; +: rejcishort? ( a n opt val neg -- a n err? ) + dup >r + lcp-got + c@ if ( a n opt val ) ( r: neg ) + >r ( a n opt ) ( r: neg val ) + >r over be-w@ wbsplit r> = swap CILEN_SHORT = and + over CILEN_SHORT >= and if ( a n ) ( r: neg val ) + CILEN_SHORT - swap getw r> <> rot swap ( a n err? ) ( r: neg ) + false lcp-try r@ + c! + else + r> drop false + then + else + 2drop false + then + r> drop +; +: rejcilong? ( a n opt val neg -- a n err? ) + dup >r + lcp-got + c@ if ( a n opt val ) ( r: neg ) + >r + >r over be-w@ wbsplit r> = swap CILEN_LONG = and + over CILEN_LONG >= and if ( a n ) ( r: neg opt ) + CILEN_LONG - swap 2+ getl r> <> rot swap ( a n err? ) ( r: neg ) + false lcp-try r@ + c! + else ( a n ) ( r: neg opt ) + r> drop false + then + else ( a n opt val ) ( r: neg ) + 2drop false + then + r> drop +; +: rejcilqr? ( a n opt val neg -- a n err? ) + dup >r + lcp-got + c@ if ( a n opt val ) ( r: neg ) + >r + >r over be-w@ wbsplit r> = swap CILEN_LQR = and + over CILEN_LQR >= and if ( a n ) ( r: neg val ) + CILEN_LQR - swap 2+ getc PPP_LQR <> + swap getl r> <> rot or rot swap ( a n err? ) ( r: neg ) + false lcp-try r@ + c! + else ( a n ) ( r: neg val ) + r> drop false + then + else ( a n opt val ) ( r: neg ) + 2drop false + then + r> drop +; +: rejcichap? ( a n opt val digest neg -- a n err? ) + dup >r + lcp-got + c@ if ( a n opt val digest ) ( r: neg ) + >r >r ( a n opt ) ( r: neg digest val ) + >r over be-w@ wbsplit r> = swap CILEN_CHAP = and + over CILEN_CHAP >= and if ( a n ) ( r: neg digest val ) + CILEN_CHAP - swap 2+ getw r> <> ( n a err ) ( r: neg digest ) + swap getc r> <> rot or rot swap ( a n err? ) ( r: neg ) + false lcp-try r@ + c! + else ( a n ) ( r: neg digest val ) + 2r> 2drop false + then + else ( a n opt val digest ) ( r: neg ) + 3drop false + then + r> drop +; +: bad-rej ( a n -- false ) + \ ." lcp_rejci received bad Reject " cr + 2drop false +; +\ Peer has Rejected some of our CIs. +\ This should not modify any state if the Reject is bad +\ or if LCP is in the OPENED state. +: lcp_rejci ( a n -- good? ) + lcp-got lcp-try /lcp move + + \ Any Rejected CIs must be in exactly the same order that we sent. + \ Check packet length and CI length at each step. + \ If we find any deviations, then this packet is bad. + CI_MRU lcp-got >mru w@ 0 >neg_mru + rejcishort? if bad-rej exit then + CI_ASYNCMAP lcp-got >asyncmap @ 0 >neg_asyncmap + rejcilong? if bad-rej exit then + CI_AUTHTYPE PPP_CHAP lcp-got >chap_mdtype c@ 0 >neg_chap + rejcichap? if bad-rej exit then + lcp-got >neg_chap c@ 0= if + CI_AUTHTYPE PPP_PAP 0 >neg_upap rejcishort? if bad-rej exit then + then + CI_QUALITY lcp-got >lqr_period @ 0 >neg_lqr + rejcilqr? if bad-rej exit then + CI_MAGICNUMBER lcp-got >magicnumber @ 0 >neg_magicnumber + rejcilong? if bad-rej exit then + CI_PCOMPRESSION 0 >neg_pcompression rejcivoid + CI_ACCOMPRESSION 0 >neg_accompression rejcivoid + ( a n ) + \ If there are any remaining CIs, then this packet is bad. + dup if bad-rej exit then ( a n ) + 2drop + + \ Now we can update state. + lcp-state OPENED <> if lcp-try lcp-got /lcp move then + true +; + +: suggest-chap ( -- ) + CI_AUTHTYPE put-nakp-char + CILEN_CHAP put-nakp-char + PPP_CHAP put-nakp-short \ suggest CHAP + lcp-allow >chap_mdtype c@ put-nakp-char +; +: suggest-pap ( -- ) + CI_AUTHTYPE put-nakp-char + CILEN_SHORT put-nakp-char + PPP_PAP put-nakp-short +; +: wants-pap ( -- result ) + lcp-his >neg_chap c@ if \ we've already accepted CHAP + \ ." lcp_reqci rejecting AUTHTYPE PAP" + CONFREJ + else + lcp-allow >neg_upap c@ 0= if \ we don't want to do PAP + suggest-chap + CONFNAK + else + true lcp-his >neg_upap c! + CONFACK + then + then +; +: wants-chap ( a -- result ) + lcp-his >neg_upap c@ if \ we've already accepted PAP + \ ." lcp_reqci rejecting AUTHTYPE CHAP" + drop CONFREJ exit + then ( a ) + + lcp-allow >neg_chap c@ 0= if ( a ) \ we don't want to do CHAP + suggest-pap ( a ) + drop CONFNAK exit + then ( a ) + + c@ dup lcp-allow >chap_mdtype c@ <> if ( digest ) + drop + suggest-chap + CONFNAK + else ( digest ) + true lcp-his >neg_chap c! + lcp-his >chap_mdtype c! ( ) + CONFACK + then +; +: wants-auth ( a -- result ) + \ Authtype must be PAP, MSCHAP (if enabled), or CHAP. + \ Note of if both ao >neg_upap and ao >neg_chap are set, + \ and the peer sends a Configure-Request with two + \ authenticate-protocol requests, one for CHAP and one + \ for PAP, then we will reject the second request. + \ Whether we end up doing CHAP or PAP depends then on + \ the ordering of the CIs in the peer's Configure-Request. + getw dup PPP_PAP = if ( a cishort ) + 2drop wants-pap exit + then ( a cishort ) + + PPP_CHAP = if ( a ) + wants-chap exit + then ( a ) + drop ( ) + + \ We don't recognize the protocol they're asking for. + \ Nak it with something we're willing to do. + lcp-allow >neg_chap c@ if + suggest-chap + else + suggest-pap + then + CONFNAK +; +: lcp-reqci-mru ( a cilen -- result ) + CILEN_SHORT <> + lcp-allow >neg_mru c@ 0= or if ( a ) + drop CONFREJ exit + then + + \ He must be able to receive at least our minimum. + \ No need to check a maximum. If he sends a large number, + \ we'll just ignore it. + be-w@ dup MINMRU < if ( cishort ) + drop + CI_MRU put-nakp-char + CILEN_SHORT put-nakp-char + MINMRU put-nakp-short \ Give him a hint + CONFNAK exit + then ( cishort ) + + true lcp-his >neg_mru c! \ remember that he sent an MRU + lcp-his >mru w! \ and the value + CONFACK +; +: lcp-reqci-async ( a cilen -- result ) + CILEN_LONG <> + lcp-allow >neg_asyncmap c@ 0= or if ( a ) + drop CONFREJ exit + then ( a ) + + \ Asyncmap must have set at least the bits + \ which are set in lcp-allow >asyncmap. + be-l@ dup invert lcp-allow >asyncmap @ and if ( cilong ) + CI_ASYNCMAP put-nakp-char + CILEN_LONG put-nakp-char + lcp-allow >asyncmap @ or put-nakp-short + CONFNAK exit + then ( cilong ) + + true lcp-his >neg_asyncmap c! + lcp-his >asyncmap ! + CONFACK +; +: lcp-reqci-auth ( a cilen -- result ) + CILEN_SHORT < if ( a ) + drop CONFREJ exit + then ( a ) + + lcp-allow >neg_upap c@ + lcp-allow >neg_chap c@ or 0= if ( a ) + \ ." we're not willing to authenticate" cr + CONFREJ exit + then ( a ) + wants-auth ( result ) +; +: lcp-reqci-lqr ( a cilen -- result ) + CILEN_LQR <> + lcp-allow >neg_lqr c@ 0= or if + drop CONFREJ exit + then ( a ) + + \ Check the protocol + be-w@ PPP_LQR <> if ( ) + CI_QUALITY put-nakp-char + CILEN_LQR put-nakp-char + PPP_LQR put-nakp-short + lcp-allow >lqr_period @ put-nakp-long + CONFNAK + else + CONFACK + then +; +: lcp-reqci-magic ( a cilen -- result ) + CILEN_LONG <> + lcp-allow >neg_magicnumber c@ + lcp-got >neg_magicnumber c@ or 0= or if ( a ) + drop CONFREJ exit + then ( a ) + + \ He must have a different magic number. + be-l@ dup lcp-got >magicnumber @ = + lcp-got >neg_magicnumber c@ and if ( cilong ) + drop + CI_MAGICNUMBER put-nakp-char + CILEN_LONG put-nakp-char + magic put-nakp-long + CONFNAK + else ( cilong ) + true lcp-his >neg_magicnumber c! + lcp-his >magicnumber ! + CONFACK + then +; +: lcp-reqci-pcomp ( a cilen -- result ) + nip CILEN_VOID <> + lcp-allow >neg_pcompression c@ 0= or if + CONFREJ + else + true lcp-his >neg_pcompression c! + true to comp_proto + CONFACK + then +; +: lcp-reqci-accomp ( a cilen -- result ) + nip CILEN_VOID <> + lcp-allow >neg_accompression c@ 0= or if + CONFREJ + else + true lcp-his >neg_accompression c! + true to comp_ac + CONFACK + then +; +: lcp-reqci-sw ( a cilen citype -- citype result ) + dup >r + case + CI_MRU of ( a cilen ) + lcp-reqci-mru ( result ) + endof + CI_ASYNCMAP of ( a cilen ) + lcp-reqci-async ( result ) + endof + CI_AUTHTYPE of + lcp-reqci-auth + endof + CI_QUALITY of + lcp-reqci-lqr + endof + CI_MAGICNUMBER of + lcp-reqci-magic + endof + CI_PCOMPRESSION of + lcp-reqci-pcomp + endof + CI_ACCOMPRESSION of + lcp-reqci-accomp + endof + ( default ) ( a cilen citype ) + >r + 2drop ( ) + \ ." lcp_reqci got unknown option " r@ . cr + CONFREJ + r> + endcase + r> swap ( citype result ) +; +\ Check the peer's requested CIs and send appropriate response. +\ Returns of CONFACK, CONFNAK or CONFREJ and input packet modified +\ appropriately. If reject_if_disagree is non-zero, doesn't return +\ CONFNAK; returns CONFREJ if it can't return CONFACK. +: lcp_reqci ( a n1 reject_if_disagree -- n2 result ) + to reject_if_disagree ( a n ) + CONFACK >r \ Final packet return code + + \ Reset all his options. + lcp-his /lcp erase + + \ Process all his options. + nak_buffer nakp ! + over ( a n next ) + dup rejp ! + begin over while + dup to cip + 2dup 1+ c@ 2 rot between 0= ( a n next bad? ) + 2 pick 2 < or if \ Reject till end of packet + \ ." lcp_reqci got bad CI length! " cr ( a n next ) + nip 0 swap \ Don't loop again + 0 CONFREJ ( a n next' citype status ) + else + dup >r + tuck 1+ c@ /string swap ( a n next' ) + r> getc swap getc rot ( a n next' next cilen citype ) + lcp-reqci-sw ( a n next' citype status ) + then + dup CONFNAK = if + swap CI_MAGICNUMBER <> + reject_if_disagree and if + drop CONFREJ + else + r@ CONFREJ <> if + r> drop CONFNAK >r + then + then + else + nip + then ( a n next' status ) + CONFREJ = if + r> drop CONFREJ >r + rejp @ cip <> if \ Need to move rejected CI? + cip rejp @ over 1+ c@ move + then + cip 1+ c@ rejp +! + then + repeat ( a n next ) + nip + r@ case + CONFACK of ( a next ) + swap - ( len ) + endof + CONFNAK of ( a next ) + \ Copy the Nak'd options from the nak_buffer to the caller's buffer. + drop + nak_buffer swap + nakp @ nak_buffer - >r + r@ move + r> ( len ) + endof + CONFREJ of ( a next ) + drop rejp @ swap - ( len ) + endof + endcase + r> ( len ret ) +; + +\ LCP has terminated the link; go to the Dead phase and take the +\ physical layer down. +: link_terminated ( -- ) + phase 0= if exit then \ 0 is PHASE_DEAD + + 0 to phase \ 0 is PHASE_DEAD + ." Connection terminated." cr + false to ppp-is-open abort +; + +\ LCP has finished with the lower layer. +: lcp_finished ( -- ) + link_terminated +; + +\ A Protocol-Reject was received. +: lcp_protrej ( -- ) + lcp-fsm fsm_protreject +; + +\ Demultiplex a Protocol-Reject. +: demuxprotrej ( protocol -- ) + \ Upcall the proper Protocol-Reject routine. + case + PPP_LCP of lcp_protrej endof + PPP_IPCP of ipcp_protrej endof + PPP_PAP of upap_protrej endof + PPP_CHAP of chap_protrej endof + \ PPP_CCP of ccp_protrej endof + ( default ) + \ ." demuxprotrej: Protocol-Reject for unrecognized protocol " dup .h cr + endcase +; + +\ Receive an Protocol-Reject. +\ Figure out which protocol is rejected and inform it. +: lcp_rprotrej ( a n -- ) + 2 < if drop exit then ( a ) + + be-w@ ( proto ) + + \ Protocol-Reject packets received in any state other than the LCP + \ OPENED state SHOULD be silently discarded. + lcp-state dup OPENED <> if ( proto state ) + \ ." Protocol-Reject discarded, LCP in state " dup . cr + 2drop exit + then ( proto state ) + drop demuxprotrej \ Inform protocol +; + +\ LCP has received a reply to the echo +: lcp_received_echo_reply ( inp len id -- ) + drop ( inp len ) + \ Check the magic number - don't count replies from ourselves. + dup 4 < if 2drop exit then + + drop be-l@ ( magic ) + lcp-got >magicnumber @ = + lcp-got >neg_magicnumber c@ and if exit then \ rec'd own echo reply + + \ Reset the number of outstanding echo frames + 0 to lcp_echos_pending +; + +\ Handle a LCP-specific code. +: lcp_extcode ( a n code id -- handled? ) + swap case + PROTREJ of ( a n id ) + nip lcp_rprotrej true + endof + ECHOREQ of ( a n id ) + lcp-state OPENED = if + lcp-got >magicnumber @ 3 pick ( inp ) swap be-l! + >r ECHOREP swap r> lcp-fsm fsm_send + else + 3drop + then true + endof + ECHOREP of ( a n id ) + lcp_received_echo_reply true + endof + DISCREQ of ( a n id ) + 3drop true + endof + ( default ) >r ( a n id ) + 3drop false + r> + endcase +; + +\ timer + +\ Time to shut down the link because there is nothing out there. +: lcp_linkfailure ( -- ) + lcp-state OPENED = if + \ ." Excessive lack of response to LCP echo frames." cr + lcp_close \ Reset connection + then +; + +variable pkt \ a short packet... +\ Send an echo request frame to the peer +: lcp_sendechorequest ( -- ) + \ Detect the failure of the peer at this point. + lcp_echo_fails if + lcp_echos_pending dup 1+ to lcp_echos_pending + lcp_echo_fails >= if + lcp-fsm lcp_linkfailure + 0 to lcp_echos_pending + then + then + + \ Make and send the echo request frame. + lcp-state OPENED = if + lcp-got >neg_magicnumber c@ if + lcp-got >magicnumber @ + else + 0 + then pkt be-l! + pkt 4 ECHOREQ + lcp_echo_number dup 1+ to lcp_echo_number h# ff and + lcp-fsm fsm_send + then +; + +\ forward reference +defer lcp_echocheck + +\ Timer expired on the LCP echo +: lcp_echotimeout ( -- ) + lcp_echo_timer_running if + false to lcp_echo_timer_running + lcp_echocheck + then +; + +\ Timer expired for the LCP echo requests from this process. +: (lcp_echocheck) ( -- ) + lcp_sendechorequest + + \ Start the timer for the next interval. + ['] lcp_echotimeout lcp-fsm lcp_echo_interval timeout + true to lcp_echo_timer_running +; +' (lcp_echocheck) to lcp_echocheck + +\ external + +\ Start the timer for the LCP frame +: lcp_echo_lowerup ( -- ) + \ Clear the parameters for generating echo frames + 0 to lcp_echos_pending + 0 to lcp_echo_number + false to lcp_echo_timer_running + + \ If a timeout interval is specified then start the timer + lcp_echo_interval if + lcp-fsm lcp_echocheck + then +; + +\ Stop the timer for the LCP frame +: lcp_echo_lowerdown ( -- ) + lcp_echo_timer_running if + ['] lcp_echotimeout lcp-fsm untimeout + false to lcp_echo_timer_running + then +; + +\ The link is established. +\ Proceed to the Dead, Authenticate or Network phase as appropriate. +: link_established ( -- ) + 2 to phase \ 2 is PHASE_AUTHENTICATE + 0 ( auth ) + lcp-his >neg_chap c@ if + chap-name lcp-his >chap_mdtype c@ chap_authwithpeer + 4 or \ CHAP_WITHPEER + else + lcp-his >neg_upap c@ if + pap-id pap-password upap_authwithpeer + 1 or \ UPAP_WITHPEER + then + then ( auth ) + dup to auth_pending + 0= if + network_phase + then +; + +\ LCP has come up. +\ Start UPAP, IPCP, etc. +: lcp_up ( -- ) + lcp-his >r + r@ >neg_magicnumber c@ if + 0 r@ >magicnumber ! + then + r@ lcp-got >r + r@ >neg_magicnumber c@ if + 0 r@ >magicnumber ! + then + >r ( rs: ho go ho ) + + \ Set our MTU to the smaller of the MTU we wanted and + \ the MRU our peer wanted. If we negotiated an MRU, + \ set our MRU to the larger of value we wanted and + \ the value we got in the negotiation. + r@ >neg_mru c@ if r@ >mru w@ else PPP_MRU then + lcp-allow >mru w@ min ( mru ) + r@ >neg_asyncmap c@ if r@ >asyncmap else -1 then + r@ >neg_pcompression c@ r> >neg_accompression c@ + ppp_send_config + ( ) ( rs: ho go ) + \ If the asyncmap hasn't been negotiated, we really should + \ set the receive asyncmap to ffff.ffff, but we set it to 0 + \ for backwards contemptibility. + r@ >neg_mru c@ if + r@ >mru w@ lcp-want >mru w@ max + else + PPP_MRU + then + r@ >neg_asyncmap c@ if r@ >asyncmap @ else 0 then + r@ >neg_pcompression c@ r> >neg_accompression c@ + ppp_recv_config ( ) ( rs: ho ) + + r@ >neg_mru c@ if + r@ >mru w@ to peer_mru + then + r> drop + + chap_lowerup \ Enable CHAP + upap_lowerup \ Enable UPAP + + ipcp-fsm fsm_lowerup \ Enable IPCP +\ ccp-fsm fsm_lowerup \ Enable CCP + lcp_echo_lowerup \ Enable echo messages + + link_established +; + +\ LCP has gone DOWN. +\ Alert other protocols. +: lcp_down ( -- ) + lcp_echo_lowerdown + \ ccp-fsm fsm_lowerdown + ipcp-fsm fsm_lowerdown + + chap_lowerdown + upap_lowerdown + + \ PPP_MRU -1 0 0 ppp_send_config + \ PPP_MRU 0 0 0 ppp_recv_config + PPP_MRU to peer_mru + + link_down +; + +create lcp-callbacks + ] + lcp_resetci lcp_cilen lcp_addci lcp_ackci lcp_nakci lcp_rejci lcp_reqci + lcp_up lcp_down lcp_finished lcp_protrej lcp_extcode + [ + +\ Initialize LCP. +: lcp_init ( -- ) + random to magic + lcp-fsm + PPP_LCP over >protocol ! + lcp-callbacks over >callbacks /fsm_callbacks move + fsm_init + + lcp-want + dup /lcp erase + DEFMRU over >mru w! + true over >neg_magicnumber c! + true over >neg_pcompression c! + true over >neg_accompression c! + CHAP_DIGEST_MD5 over >chap_mdtype c! + drop + + lcp-allow + dup /lcp erase + MAXMRU over >mru w! + true over >neg_mru c! + true over >neg_asyncmap c! + \ false over >neg_chap c! + true over >neg_chap c! + true over >neg_upap c! + true over >neg_magicnumber c! + true over >neg_pcompression c! + true over >neg_accompression c! + CHAP_DIGEST_MD5 over >chap_mdtype c! + drop + + xmit_accm 32 erase + h# 60000000 xmit_accm 3 la+ ! +; + +\ Send a Protocol-Reject for some protocol. +: lcp_sprotrej ( a n -- ) + \ Send back the protocol and the information field of the + \ rejected packet. We only get here if LCP is in the OPENED state. + PROTREJ lcp-fsm next-id lcp-fsm fsm_send +; + +\ The lower layer is up. +: lcp_lowerup ( -- ) + \ xmit_accm ppp_set_xaccm + \ PPP_MRU h# ffffffff 0 0 ppp_send_config + \ PPP_MRU h# 00000000 0 0 ppp_recv_config + PPP_MRU to peer_mru + xmit_accm @ lcp-allow >asyncmap ! + + lcp-fsm fsm_lowerup +; + +\ The lower layer is down. +: lcp_lowerdown ( -- ) lcp-fsm fsm_lowerdown ; + +\ Input LCP packet. +: lcp_input ( a n -- ) + lcp-state -rot ( oldstate a n ) + lcp-fsm fsm_input ( oldstate ) + REQSENT = lcp-state ACKSENT = and if + \ The peer will probably send us an ack soon and then + \ immediately start sending packets with the negotiated + \ options. So as to be ready when that happens, we set + \ our receive side to accept packets as negotiated now. + lcp-got >r + r@ >neg_asyncmap c@ dup if + drop r@ >asyncmap + then + r@ >neg_pcompression c@ + r> >neg_accompression c@ + PPP_MRU ppp_recv_config \ XXX arg order? + then +; +\ LICENSE_BEGIN +\ Copyright (c) 2006 FirmWorks +\ +\ Permission is hereby granted, free of charge, to any person obtaining +\ a copy of this software and associated documentation files (the +\ "Software"), to deal in the Software without restriction, including +\ without limitation the rights to use, copy, modify, merge, publish, +\ distribute, sublicense, and/or sell copies of the Software, and to +\ permit persons to whom the Software is furnished to do so, subject to +\ the following conditions: +\ +\ The above copyright notice and this permission notice shall be +\ included in all copies or substantial portions of the Software. +\ +\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +\ +\ LICENSE_END diff --git a/src/ofw/ppp/loadpkg.fth b/src/ofw/ppp/loadpkg.fth new file mode 100644 index 0000000..fdc877c --- /dev/null +++ b/src/ofw/ppp/loadpkg.fth @@ -0,0 +1,46 @@ +\ See license at end of file +purpose: Load PPP + +fload ${BP}/ofw/ppp/const.fth +fload ${BP}/ofw/ppp/vars.fth +fload ${BP}/ofw/ppp/utility.fth + +fload ${BP}/ofw/ppp/fcs.fth +fload ${BP}/ofw/ppp/framing.fth + +fload ${BP}/ofw/ppp/timeout.fth + +fload ${BP}/ofw/ppp/fsm.fth +fload ${BP}/ofw/ppp/ipcp.fth +\ fload ${BP}/ofw/ppp/ccp.fth + +fload ${BP}/ofw/ppp/auth.fth +fload ${BP}/ofw/ppp/upap.fth +fload ${BP}/ofw/ppp/chap.fth +fload ${BP}/ofw/ppp/lcp.fth + +fload ${BP}/ofw/ppp/ip.fth +fload ${BP}/ofw/ppp/main.fth +\ LICENSE_BEGIN +\ Copyright (c) 2006 FirmWorks +\ +\ Permission is hereby granted, free of charge, to any person obtaining +\ a copy of this software and associated documentation files (the +\ "Software"), to deal in the Software without restriction, including +\ without limitation the rights to use, copy, modify, merge, publish, +\ distribute, sublicense, and/or sell copies of the Software, and to +\ permit persons to whom the Software is furnished to do so, subject to +\ the following conditions: +\ +\ The above copyright notice and this permission notice shall be +\ included in all copies or substantial portions of the Software. +\ +\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +\ +\ LICENSE_END diff --git a/src/ofw/ppp/loadppp.fth b/src/ofw/ppp/loadppp.fth new file mode 100644 index 0000000..f78b9ee --- /dev/null +++ b/src/ofw/ppp/loadppp.fth @@ -0,0 +1,43 @@ +\ See license at end of file +purpose: Load file for PPP and dialer extensions + +\ This feature depends on the existence of a support package named +\ "ppp-info", which keeps track of PPP and dialer configuration information. +\ This load file does not load the ppp-info support package, because the +\ storage mechanism for that information is system-dependent. + +fload ${BP}/ofw/ppp/pppinfo.fth +fload ${BP}/ofw/tip.fth + +[ifdef] resident-packages +support-package: ppp + fload ${BP}/ofw/ppp/loadpkg.fth +end-support-package + +support-package: dial + fload ${BP}/ofw/dial.fth +end-support-package +[then] +\ LICENSE_BEGIN +\ Copyright (c) 2006 FirmWorks +\ +\ Permission is hereby granted, free of charge, to any person obtaining +\ a copy of this software and associated documentation files (the +\ "Software"), to deal in the Software without restriction, including +\ without limitation the rights to use, copy, modify, merge, publish, +\ distribute, sublicense, and/or sell copies of the Software, and to +\ permit persons to whom the Software is furnished to do so, subject to +\ the following conditions: +\ +\ The above copyright notice and this permission notice shall be +\ included in all copies or substantial portions of the Software. +\ +\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +\ +\ LICENSE_END diff --git a/src/ofw/ppp/main.fth b/src/ofw/ppp/main.fth new file mode 100644 index 0000000..7e51165 --- /dev/null +++ b/src/ofw/ppp/main.fth @@ -0,0 +1,146 @@ +\ See license at end of file +purpose: Point-to-Point Protocol main module + +: init_vars ( -- ) + 0 to comp_ac + 0 to comp_proto + 0 to auth_pending + 0 to read-xt + 0 to ipin + false to looped_back + random to magic +; + +: handle_input ( a n protocol -- ) + case + PPP_LCP of lcp_input endof + PPP_IPCP of ipcp_input endof + PPP_PAP of upap_input endof + PPP_CHAP of chap_input endof + \ PPP_CCP of ccp_input endof + \ PPP_CCPD of ccp_datainput endof + PPP_IP of ip_input endof + ( default ) + >r + -2 /string lcp_sprotrej + r> + endcase +; +\ called when incoming data is available. +: (get_input) ( -- ) + calltimeout ( ) + poll-packet 0= if ( hangup? ) + if ( ) + ." Modem hangup" cr + true to hungup + lcp_lowerdown \ serial link is no longer available + link_terminated + then + exit + then ( a n ) + + phase 4 = if \ 4 is PHASE_TERMINATE + 2drop + lcp_lowerdown \ serial link is no longer available + link_terminated + exit + then + + dup PPP_HDRLEN < if 2drop exit then ( a n ) + + \ check length of protocol field + over c@ 1 and if + 1 /string over 1- c@ + else + 2 /string over 2- be-w@ + then ( a n protocol ) + + \ Toss all non-LCP packets unless LCP is OPEN. + dup PPP_LCP <> lcp-state OPENED <> + and if 3drop exit then ( a n protocol ) + + handle_input +; +' (get_input) to get_input + +: close ( -- ) + clear-timeouts + lcp_close + close-com + false to ppp-is-open +; + +: open ( -- okay? ) + init_vars + 0 to hungup + 0 to ppp-is-open + init-framer + + \ Initialize + lcp_init + ipcp_init + upap_init + chap_init + \ ccp_init + + \ Open the serial device + open-com if false exit then + + lcp_lowerup + lcp_open \ Start protocol + 1 to phase \ 1 is PHASE_ESTABLISH + get-msecs d# 60000 + + begin + get-msecs over - 0< + while + phase 0= hungup or if \ 0 is PHASE_DEAD + close + leave + then + get_input + ppp-is-open + until then ( time-limit ) + drop + ppp-is-open dup if + d# 200 ms + then +; + +h# 80 buffer: tips +: tip ( -- ) + begin + key? if + key dup 3 = if drop exit then + tips c! tips 1 tty-write drop + then + tips h# 80 tty-read dup 0> if + tips swap type + else + drop + then + again +; +0 " #address-bits" integer-property +\ LICENSE_BEGIN +\ Copyright (c) 2006 FirmWorks +\ +\ Permission is hereby granted, free of charge, to any person obtaining +\ a copy of this software and associated documentation files (the +\ "Software"), to deal in the Software without restriction, including +\ without limitation the rights to use, copy, modify, merge, publish, +\ distribute, sublicense, and/or sell copies of the Software, and to +\ permit persons to whom the Software is furnished to do so, subject to +\ the following conditions: +\ +\ The above copyright notice and this permission notice shall be +\ included in all copies or substantial portions of the Software. +\ +\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +\ +\ LICENSE_END diff --git a/src/ofw/ppp/md5.fth b/src/ofw/ppp/md5.fth new file mode 100644 index 0000000..375915c --- /dev/null +++ b/src/ofw/ppp/md5.fth @@ -0,0 +1,310 @@ +purpose: PPP MD5 Message-digest routines + +\ RSA Data Security, Inc. MD5 Message-Digest Algorithm + +\ To form the message digest for a message M +\ (1) Initialize using md5init +\ (2) Call md5update and M for at least one M +\ (3) Call md5final +\ The message digest is now in md5digest[0...15] + +[ifdef] notdef +This file was translated into Forth from md5.h and md5.c in the Linux +source code, which contained the following: + +/* + *********************************************************************** + ** md5.h -- header file for implementation of MD5 ** + ** RSA Data Security, Inc. MD5 Message-Digest Algorithm ** + ** Created: 2/17/90 RLR ** + ** Revised: 12/27/90 SRD,AJ,BSK,JT Reference C version ** + ** Revised (for MD5): RLR 4/27/91 ** + ** -- G modified to have y&~z instead of y&z ** + ** -- FF, GG, HH modified to add in last register done ** + ** -- Access pattern: round 2 works mod 5, round 3 works mod 3 ** + ** -- distinct additive constant for each step ** + ** -- round 4 added, working mod 7 ** + *********************************************************************** + */ + +/* + *********************************************************************** + ** Copyright (C) 1990, RSA Data Security, Inc. All rights reserved. ** + ** ** + ** License to copy and use this software is granted provided that ** + ** it is identified as the "RSA Data Security, Inc. MD5 Message- ** + ** Digest Algorithm" in all material mentioning or referencing this ** + ** software or this function. ** + ** ** + ** License is also granted to make and use derivative works ** + ** provided that such works are identified as "derived from the RSA ** + ** Data Security, Inc. MD5 Message-Digest Algorithm" in all ** + ** material mentioning or referencing the derived work. ** + ** ** + ** RSA Data Security, Inc. makes no representations concerning ** + ** either the merchantability of this software or the suitability ** + ** of this software for any particular purpose. It is provided "as ** + ** is" without express or implied warranty of any kind. ** + ** ** + ** These notices must be retained in any copies of any part of this ** + ** documentation and/or software. ** + *********************************************************************** + */ +[then] + +\ This code only works right on 32-bit systems + +decimal + +headers +16 constant /digest +/digest buffer: md5digest \ contains result after MD5Final call + +headerless +64 buffer: md5input \ input buffer +16 /l* buffer: md5xin \ transformation input buffer +04 /l* buffer: md5buf \ scratch buffer + +0 value md5count + +\ MD5 primitives + +\ x y and x invert z and or +: md5F ( x y z -- n ) -rot over and -rot invert and or ; + +\ z x and z invert y and or +: md5G ( x y z -- n ) tuck invert and -rot and or ; + +: md5H ( x y z -- n ) xor xor ; + +\ x z invert or y xor +: md5I ( x y z -- n ) invert rot or xor ; + +: rotate_left ( x n -- y ) 2dup lshift -rot 32 swap - rshift or ; + +\ FF, GG, HH, and II transformations for rounds 1, 2, 3, and 4 + +: md5FF ( a b c d x s e -- ) + swap >r + >r ( a b c d ) ( r: s x+e ) + rot @ dup >r rot @ rot @ md5F ( a F ) ( r: s x+e b@ ) + over @ + r> swap r> + ( a b@ first ) ( r: s ) + r> rotate_left + swap ! +; +: GG ( a b c d x s e - ) + swap >r + >r ( a b c d ) ( r: s x+e ) + rot @ dup >r rot @ rot @ md5G ( a F ) ( r: s x+e b@ ) + over @ + r> swap r> + ( a b@ first ) ( r: s ) + r> rotate_left + swap ! +; +: HH ( a b c d x s e -- ) + swap >r + >r ( a b c d ) ( r: s x+e ) + rot @ dup >r rot @ rot @ md5H ( a F ) ( r: s x+e b@ ) + over @ + r> swap r> + ( a b@ first ) ( r: s ) + r> rotate_left + swap ! +; +: II ( a b c d x s e - ) + swap >r + >r ( a b c d ) ( r: s x+e ) + rot @ dup >r rot @ rot @ md5I ( a F ) ( r: s x+e b@ ) + over @ + r> swap r> + ( a b@ first ) ( r: s ) + r> rotate_left + swap ! +; + +: l+! ( n a -- ) dup l@ rot + swap l! ; + +\ Basic MD5 step. Transforms md5buf based on md5input. +variable md5a +variable md5b +variable md5c +variable md5d +7 constant S11 +12 constant S12 +17 constant S13 +22 constant S14 +5 constant S21 +9 constant S22 +14 constant S23 +20 constant S24 +4 constant S31 +11 constant S32 +16 constant S33 +23 constant S34 +6 constant S41 +10 constant S42 +15 constant S43 +21 constant S44 +: Transform ( buf in -- ) + swap >r + r@ 0 la+ l@ md5a ! + r@ 1 la+ l@ md5b ! + r@ 2 la+ l@ md5c ! + r@ 3 la+ l@ md5d ! + + >r + + \ Round 1 + md5a md5b md5c md5d r@ 0 la+ l@ S11 3614090360 md5FF \ 1 + md5d md5a md5b md5c r@ 1 la+ l@ S12 3905402710 md5FF \ 2 + md5c md5d md5a md5b r@ 2 la+ l@ S13 606105819 md5FF \ 3 + md5b md5c md5d md5a r@ 3 la+ l@ S14 3250441966 md5FF \ 4 + md5a md5b md5c md5d r@ 4 la+ l@ S11 4118548399 md5FF \ 5 + md5d md5a md5b md5c r@ 5 la+ l@ S12 1200080426 md5FF \ 6 + md5c md5d md5a md5b r@ 6 la+ l@ S13 2821735955 md5FF \ 7 + md5b md5c md5d md5a r@ 7 la+ l@ S14 4249261313 md5FF \ 8 + md5a md5b md5c md5d r@ 8 la+ l@ S11 1770035416 md5FF \ 9 + md5d md5a md5b md5c r@ 9 la+ l@ S12 2336552879 md5FF \ 10 + md5c md5d md5a md5b r@ 10 la+ l@ S13 4294925233 md5FF \ 11 + md5b md5c md5d md5a r@ 11 la+ l@ S14 2304563134 md5FF \ 12 + md5a md5b md5c md5d r@ 12 la+ l@ S11 1804603682 md5FF \ 13 + md5d md5a md5b md5c r@ 13 la+ l@ S12 4254626195 md5FF \ 14 + md5c md5d md5a md5b r@ 14 la+ l@ S13 2792965006 md5FF \ 15 + md5b md5c md5d md5a r@ 15 la+ l@ S14 1236535329 md5FF \ 16 + + \ Round 2 + md5a md5b md5c md5d r@ 1 la+ l@ S21 4129170786 GG \ 17 + md5d md5a md5b md5c r@ 6 la+ l@ S22 3225465664 GG \ 18 + md5c md5d md5a md5b r@ 11 la+ l@ S23 643717713 GG \ 19 + md5b md5c md5d md5a r@ 0 la+ l@ S24 3921069994 GG \ 20 + md5a md5b md5c md5d r@ 5 la+ l@ S21 3593408605 GG \ 21 + md5d md5a md5b md5c r@ 10 la+ l@ S22 38016083 GG \ 22 + md5c md5d md5a md5b r@ 15 la+ l@ S23 3634488961 GG \ 23 + md5b md5c md5d md5a r@ 4 la+ l@ S24 3889429448 GG \ 24 + md5a md5b md5c md5d r@ 9 la+ l@ S21 568446438 GG \ 25 + md5d md5a md5b md5c r@ 14 la+ l@ S22 3275163606 GG \ 26 + md5c md5d md5a md5b r@ 3 la+ l@ S23 4107603335 GG \ 27 + md5b md5c md5d md5a r@ 8 la+ l@ S24 1163531501 GG \ 28 + md5a md5b md5c md5d r@ 13 la+ l@ S21 2850285829 GG \ 29 + md5d md5a md5b md5c r@ 2 la+ l@ S22 4243563512 GG \ 30 + md5c md5d md5a md5b r@ 7 la+ l@ S23 1735328473 GG \ 31 + md5b md5c md5d md5a r@ 12 la+ l@ S24 2368359562 GG \ 32 + + \ Round 3 + md5a md5b md5c md5d r@ 5 la+ l@ S31 4294588738 HH \ 33 + md5d md5a md5b md5c r@ 8 la+ l@ S32 2272392833 HH \ 34 + md5c md5d md5a md5b r@ 11 la+ l@ S33 1839030562 HH \ 35 + md5b md5c md5d md5a r@ 14 la+ l@ S34 4259657740 HH \ 36 + md5a md5b md5c md5d r@ 1 la+ l@ S31 2763975236 HH \ 37 + md5d md5a md5b md5c r@ 4 la+ l@ S32 1272893353 HH \ 38 + md5c md5d md5a md5b r@ 7 la+ l@ S33 4139469664 HH \ 39 + md5b md5c md5d md5a r@ 10 la+ l@ S34 3200236656 HH \ 40 + md5a md5b md5c md5d r@ 13 la+ l@ S31 681279174 HH \ 41 + md5d md5a md5b md5c r@ 0 la+ l@ S32 3936430074 HH \ 42 + md5c md5d md5a md5b r@ 3 la+ l@ S33 3572445317 HH \ 43 + md5b md5c md5d md5a r@ 6 la+ l@ S34 76029189 HH \ 44 + md5a md5b md5c md5d r@ 9 la+ l@ S31 3654602809 HH \ 45 + md5d md5a md5b md5c r@ 12 la+ l@ S32 3873151461 HH \ 46 + md5c md5d md5a md5b r@ 15 la+ l@ S33 530742520 HH \ 47 + md5b md5c md5d md5a r@ 2 la+ l@ S34 3299628645 HH \ 48 + + \ Round 4 + md5a md5b md5c md5d r@ 0 la+ l@ S41 4096336452 II \ 49 + md5d md5a md5b md5c r@ 7 la+ l@ S42 1126891415 II \ 50 + md5c md5d md5a md5b r@ 14 la+ l@ S43 2878612391 II \ 51 + md5b md5c md5d md5a r@ 5 la+ l@ S44 4237533241 II \ 52 + md5a md5b md5c md5d r@ 12 la+ l@ S41 1700485571 II \ 53 + md5d md5a md5b md5c r@ 3 la+ l@ S42 2399980690 II \ 54 + md5c md5d md5a md5b r@ 10 la+ l@ S43 4293915773 II \ 55 + md5b md5c md5d md5a r@ 1 la+ l@ S44 2240044497 II \ 56 + md5a md5b md5c md5d r@ 8 la+ l@ S41 1873313359 II \ 57 + md5d md5a md5b md5c r@ 15 la+ l@ S42 4264355552 II \ 58 + md5c md5d md5a md5b r@ 6 la+ l@ S43 2734768916 II \ 59 + md5b md5c md5d md5a r@ 13 la+ l@ S44 1309151649 II \ 60 + md5a md5b md5c md5d r@ 4 la+ l@ S41 4149444226 II \ 61 + md5d md5a md5b md5c r@ 11 la+ l@ S42 3174756917 II \ 62 + md5c md5d md5a md5b r@ 2 la+ l@ S43 718787259 II \ 63 + md5b md5c md5d md5a r@ 9 la+ l@ S44 3951481745 II \ 64 + + r> drop + + md5a @ r@ 0 la+ l+! + md5b @ r@ 1 la+ l+! + md5c @ r@ 2 la+ l+! + md5d @ r> 3 la+ l+! +; + +headers +\ The routine md5init initializes the message-digest context +: md5init ( -- ) + 0 to md5count + + \ Load magic initialization constants. + md5buf + h# 67452301 over l! la1+ + h# efcdab89 over l! la1+ + h# 98badcfe over l! la1+ + h# 10325476 swap l! ( ) +; + +headerless +: md5-addchar ( mdi char -- mdi' ) + \ add new character to buffer, increment mdi + over md5input + c! 1+ ( mdi ) + + \ transform if necessary + dup h# 40 = if + drop ( ) + 16 0 do + md5input i la+ le-l@ md5xin i la+ l! + loop + md5buf md5xin Transform + 0 ( mdi ) + then +; + +headers +\ The routine md5update updates the message-digest context to +\ account for the presence of each of the characters inBuf[0..inLen-1] +\ in the message whose digest is being computed. +: md5update ( inBuf inLen -- ) + \ compute number of bytes mod 64 + md5count h# 3f and ( inBuf inLen mdi ) + + \ update number of bytes + over md5count + to md5count ( inBuf inLen mdi ) + + -rot ( mdi inBuf inLen ) + bounds ?do i c@ md5-addchar loop ( mdi ) + drop +; + +\ The routine md5final terminates the message-digest computation and +\ ends with the desired message digest in md5digest[0...15]. +: md5final ( -- ) + \ pad out length to 56 mod 64 + md5count h# 3f and ( mdi ) + dup 56 < if 56 else 120 then over - ( mdi padlen ) + dup if + swap h# 80 md5-addchar ( padlen mdi ) + swap 1- 0 ?do 0 md5-addchar loop drop + else + 2drop + then + + \ transfer 56 bytes to transformation input buffer + 14 0 do + md5input i la+ le-l@ md5xin i la+ l! + loop + + \ append original length in bits + md5count 3 lshift md5xin 14 la+ l! ( bytes ) + 0 md5xin 15 la+ l! ( ) + + \ and transform + md5buf md5xin Transform + + \ copy buffer to digest + 4 0 do ( ) + md5buf i la+ l@ md5digest i la+ le-l! + loop +; +: md5end ( -- digest$ ) MD5Final md5digest /digest ; + +: $md5digest1 ( $1 -- digest$ ) + MD5Init ( a n ) + MD5Update ( ) + md5end ( digest$ ) +; +: $md5digest2 ( $1 $2 -- digest$ ) + MD5Init ( $1 $2 ) + 2swap MD5Update MD5Update ( ) + md5end ( digest$ ) +; diff --git a/src/ofw/ppp/pppinfo.fth b/src/ofw/ppp/pppinfo.fth new file mode 100644 index 0000000..a55059c --- /dev/null +++ b/src/ofw/ppp/pppinfo.fth @@ -0,0 +1,103 @@ +\ See license at end of file +purpose: Interface to PPP information package + +0 value ppp-info-ih +: close-ppp-info ( -- ) ppp-info-ih close-package 0 to ppp-info-ih ; +: open-ppp-info ( package-name$ -- ) + ppp-info-ih if close-ppp-info then ( package-name$ ) + [char] : left-parse-string $open-package to ppp-info-ih + ppp-info-ih 0= abort" Can't open PPP info" +; + +: ?open-ppp-info ( -- ) + ppp-info-ih 0= if " ppp-info" open-ppp-info then +; + +: $ppp-info ( ??? name$ -- ??? ) ?open-ppp-info ppp-info-ih $call-method ; + +: save-ppp-info ( -- ) " save" $ppp-info ; +: set-ppp-info-field ( value$ name$ -- ) + $ppp-info 2drop " replace-last" $ppp-info +; +: clear-ppp-info ( -- ) + " ppp-info:repair" open-ppp-info + " reset" $ppp-info + save-ppp-info + close-ppp-info +; +: set-default-ppp-info ( -- ) + clear-ppp-info + " 3" " #retries" set-ppp-info-field + " 38400" " baud" set-ppp-info-field + " Others" " modem-name" set-ppp-info-field + " ATZ" " modem-init$" set-ppp-info-field + " ATDT" " modem-dial$" set-ppp-info-field + " +++" " modem-interrupt$" set-ppp-info-field + " ATH" " modem-hangup$" set-ppp-info-field + " Others" " modem-name" set-ppp-info-field + " No Login Script" " script" set-ppp-info-field + save-ppp-info +; + +: ?save-ppp-info ( -- ) + " Save changes in CMOS RAM?" confirmed? if save-ppp-info then +; +: $edit-item ( name$ -- ) + 2dup type ." : " $ppp-info $edit " replace-last" $ppp-info +; + +: edit-ppp-info ( -- ) + " phone#" $edit-item + " #retries" $edit-item + " baud" $edit-item + " dns-server0" $edit-item + " dns-server1" $edit-item + " domain-name" $edit-item + " javaos-config-url" $edit-item + " client-ip" $edit-item + " modem-name" $edit-item + " modem-init$" $edit-item + " modem-dial$" $edit-item + " modem-interrupt$" $edit-item + " modem-hangup$" $edit-item + " script" $edit-item + " expect$1" $edit-item + " expect$2" $edit-item + " expect$3" $edit-item + " expect$4" $edit-item + " expect$5" $edit-item + " send$1" $edit-item + " send$2" $edit-item + " send$3" $edit-item + " send$4" $edit-item + " send$5" $edit-item + " pap-id" $edit-item + " pap-password" $edit-item + " chap-name" $edit-item + " chap-secret" $edit-item + + ?save-ppp-info +; +\ LICENSE_BEGIN +\ Copyright (c) 2006 FirmWorks +\ +\ Permission is hereby granted, free of charge, to any person obtaining +\ a copy of this software and associated documentation files (the +\ "Software"), to deal in the Software without restriction, including +\ without limitation the rights to use, copy, modify, merge, publish, +\ distribute, sublicense, and/or sell copies of the Software, and to +\ permit persons to whom the Software is furnished to do so, subject to +\ the following conditions: +\ +\ The above copyright notice and this permission notice shall be +\ included in all copies or substantial portions of the Software. +\ +\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +\ +\ LICENSE_END diff --git a/src/ofw/ppp/timeout.fth b/src/ofw/ppp/timeout.fth new file mode 100644 index 0000000..3e309d1 --- /dev/null +++ b/src/ofw/ppp/timeout.fth @@ -0,0 +1,100 @@ +\ See license at end of file +purpose: PPP timeouts + +decimal + +listnode + /n field >c_next \ link + /n field >c_time \ time at which to call routine + /n field >c_arg \ argument to routine + /n field >c_func \ routine +nodetype: callout-node + +list: callouts +0 callouts ! + +: set-callout ( func arg seconds node -- time ) + >r ( func arg seconds ) + -rot r@ >c_arg ! r@ >c_func ! ( seconds ) + d# 1000 * get-msecs + dup r> >c_time ! ( time ) +; +: call-after? ( time node -- time after? ) >c_time @ over u> ; +: call-before? ( time node -- time after? ) >c_time @ over u<= ; + +\ Schedule a timeout. +\ Note that this timeout takes the number of seconds, +: timeout ( func arg seconds -- ) + \ Allocate timeout. + callout-node allocate-node dup >r ( func arg seconds new ) ( r: new ) + set-callout ( time ) ( r: new ) + r> swap ( new time ) + + callouts ['] call-after? find-node drop ( new time prev ) + nip insert-after +; + +: call-match? ( func arg node -- func arg match? ) + 2dup >c_arg @ = 3 pick rot >c_func @ = and +; +\ Unschedule a timeout. +: untimeout ( func arg -- ) + callouts ['] call-match? find-node if ( func arg prev ) + delete-after callout-node free-node + then + 2drop +; + +: exec-timeout ( node -- ) + dup >c_arg @ swap >c_func @ execute +; + +\ Call any timeout routines which are now due. +: calltimeout ( -- ) + get-msecs ( time ) + begin + callouts ['] call-before? find-node ( time prev node|0 ) + ?dup while ( time prev node ) + exec-timeout ( time prev ) + delete-after callout-node free-node ( time ) + repeat ( time prev ) + 2drop +; + +\ return the length of time until the next timeout is due, or 0 if none +: timeleft ( -- n ) + callouts @ dup if + >c_time @ get-msecs - + then +; + +: clear-timeouts ( -- ) + callouts @ ( node ) + begin dup while ( node ) + dup >next-node swap ( node' node ) + callout-node free-node ( node' ) + repeat ( 0 ) + callouts ! +; +\ LICENSE_BEGIN +\ Copyright (c) 2006 FirmWorks +\ +\ Permission is hereby granted, free of charge, to any person obtaining +\ a copy of this software and associated documentation files (the +\ "Software"), to deal in the Software without restriction, including +\ without limitation the rights to use, copy, modify, merge, publish, +\ distribute, sublicense, and/or sell copies of the Software, and to +\ permit persons to whom the Software is furnished to do so, subject to +\ the following conditions: +\ +\ The above copyright notice and this permission notice shall be +\ included in all copies or substantial portions of the Software. +\ +\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +\ +\ LICENSE_END diff --git a/src/ofw/ppp/upap.fth b/src/ofw/ppp/upap.fth new file mode 100644 index 0000000..ed39fb1 --- /dev/null +++ b/src/ofw/ppp/upap.fth @@ -0,0 +1,169 @@ +\ See license at end of file +purpose: UPAP -- PPP User Password Authentication Protocol + +decimal + +258 buffer: upap_username +258 buffer: upap_password + +variable upap_transmits + +0 value upap-to + +0 value upap_id +0 value upap-clientstate + +: set-upap-state ( state -- ) + show-states? if ." upap " dup .state-name then + to upap-clientstate +; +: authreq? ( -- flag ) upap-clientstate AUTHREQ = ; \ A common query + +\ Send an Authenticate-Request. +: upap_sauthreq ( -- ) + upap_username c@ upap_password c@ + HEADERLEN + 2+ ( outlen ) + + PPP_PAP outpacket_buf makeheader ( outlen outp ) + upap_id 1+ to upap_id + 1 putc upap_id putc swap putw \ 1 is UPAP_AUTHREQ ( outp ) + upap_username c@ putc + upap_username count puts + upap_password c@ putc + upap_password count puts ( outp ) + outpacket_buf tuck - ppp-write drop ( ) + + upap-to 0 3 timeout \ 3 is UPAP_DEFTIMEOUT + 1 upap_transmits +! + AUTHREQ set-upap-state +; + +\ Retransmission timer for sending auth-reqs expired. +: upap_timeout ( arg -- ) + drop authreq? 0= if exit then + + upap_transmits @ d# 10 >= if + \ give up in disgust + BADAUTH set-upap-state + 1 auth_withpeer_fail + exit + then + + upap_sauthreq \ Send Authenticate-Request +; + +\ Initialize a UPAP unit. +: upap_init ( -- ) + 0 upap_username c! + 0 upap_password c! + 0 to upap_id + INITIAL set-upap-state + ['] upap_timeout to upap-to +; + +\ Give up waiting for the peer to send an auth-req. +\ The lower layer is up. +\ Start authenticating if pending. +: upap_lowerup ( -- ) + + upap-clientstate case + INITIAL of CLOSED set-upap-state endof + PENDING of upap_sauthreq endof + endcase +; + +\ The lower layer is down. +\ Cancel all timeouts. +: upap_lowerdown ( -- ) + \ Cancel timeout if one is pending + authreq? if ['] upap_timeout 0 untimeout then + INITIAL set-upap-state +; + + +\ Peer doesn't speak this protocol. +\ This shouldn't happen. In any case, pretend lower layer went down. +: upap_protrej ( -- ) + authreq? if 1 auth_withpeer_fail then \ Timeout pending? + upap_lowerdown +; + +: bad-auth-msg? ( a n id -- flag ) + drop authreq? 0= if 2drop true exit then ( a n ) + + \ Parse message. + dup 1 < if 2drop true exit then ( a n ) + + swap count rot 1- over < if 2drop false exit then ( a msglen ) + 2drop \ type cr + false +; + +\ Receive Authenticate-Ack. +: upap_rauthack ( a n id -- ) + bad-auth-msg? if exit then + + OPENED set-upap-state + + ['] upap_timeout 0 untimeout \ Cancel timeout + 1 auth_withpeer_success \ UPAP_WITHPEER +; + +\ Receive Authenticate-Nakk. +: upap_rauthnak ( a n id -- ) + bad-auth-msg? if exit then + + 5 set-upap-state \ 5 is UPAPCS_BADAUTH + + BADAUTH set-upap-state + 1 auth_withpeer_fail +; + +\ Input UPAP packet. +: upap_input ( a n -- ) + dup HEADERLEN < if 2drop exit then ( a n ) + + over 2+ be-w@ dup HEADERLEN < if 3drop exit then ( a n len ) + tuck < if 3drop exit then ( a n ) + + over dup 1+ c@ swap c@ case + 2 of upap_rauthack endof \ UPAP_AUTHACK ( a n id ) + 3 of upap_rauthnak endof \ UPAP_AUTHNAK ( a n id ) + 3drop + endcase +; + +\ Authenticate us with our peer (start client). +: upap_authwithpeer ( $user $password -- ) + upap_password place upap_username place 0 upap_transmits ! + + \ Lower layer up yet? + upap-clientstate case + INITIAL of PENDING set-upap-state exit endof + PENDING of exit endof + endcase + + upap_sauthreq \ Start protocol +; +\ LICENSE_BEGIN +\ Copyright (c) 2006 FirmWorks +\ +\ Permission is hereby granted, free of charge, to any person obtaining +\ a copy of this software and associated documentation files (the +\ "Software"), to deal in the Software without restriction, including +\ without limitation the rights to use, copy, modify, merge, publish, +\ distribute, sublicense, and/or sell copies of the Software, and to +\ permit persons to whom the Software is furnished to do so, subject to +\ the following conditions: +\ +\ The above copyright notice and this permission notice shall be +\ included in all copies or substantial portions of the Software. +\ +\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +\ +\ LICENSE_END diff --git a/src/ofw/ppp/utility.fth b/src/ofw/ppp/utility.fth new file mode 100644 index 0000000..de740fa --- /dev/null +++ b/src/ofw/ppp/utility.fth @@ -0,0 +1,56 @@ +\ See license at end of file +purpose: Miscellaneous Tools + +\ random numbers +here value seed +: random ( -- u ) seed h# 107465 * h# 234567 + dup to seed ; +\ : choose ( n -- u ) ( 0 <= u < n ) random um* nip ; +random value magic + +\ manage data fields +: getc ( a1 -- a2 c ) count ; +: gets ( a1 n -- a2 a1 ) over + swap ; +: getw ( a1 -- a2 w ) dup wa1+ swap be-w@ ; +: getl ( a1 -- a2 l ) dup la1+ swap be-l@ ; +: putc ( a1 c -- a2 ) over c! 1+ ; +: puts ( a1 a n -- a2 ) bounds ?do i c@ putc loop ; +: putw ( a1 w -- a2 ) over be-w! wa1+ ; +: putl ( a1 l -- a2 ) over be-l! la1+ ; + +\ using a pointer variable... +: putchar ( c p -- ) tuck @ c! 1 swap +! ; +: putshort ( w p -- ) tuck @ be-w! 2 swap +! ; +: putlong ( l p -- ) tuck @ be-l! 4 swap +! ; + +\ Add Header fields to a packet. +: makeheader ( proto a1 -- a2 ) h# ff03 putw swap putw ; + +\ stubs +: ppp_send_config 4drop ; +: ppp_recv_config 4drop ; +: ppp_set_xaccm drop ; + + +\ LICENSE_BEGIN +\ Copyright (c) 2006 FirmWorks +\ +\ Permission is hereby granted, free of charge, to any person obtaining +\ a copy of this software and associated documentation files (the +\ "Software"), to deal in the Software without restriction, including +\ without limitation the rights to use, copy, modify, merge, publish, +\ distribute, sublicense, and/or sell copies of the Software, and to +\ permit persons to whom the Software is furnished to do so, subject to +\ the following conditions: +\ +\ The above copyright notice and this permission notice shall be +\ included in all copies or substantial portions of the Software. +\ +\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +\ +\ LICENSE_END diff --git a/src/ofw/ppp/vars.fth b/src/ofw/ppp/vars.fth new file mode 100644 index 0000000..38e8195 --- /dev/null +++ b/src/ofw/ppp/vars.fth @@ -0,0 +1,51 @@ +\ See license at end of file +purpose: Variables + +decimal + +false value show-states? +\ true to show-states? + +false value show-packets? +\ true to show-packets? + +\ Global variables. +0 value phase \ Current state of link - see values below +1500 value peer_mru \ currently negotiated peer MRU (per unit) + +\ Flags +0 value comp_ac +0 value comp_proto +0 value ppp-is-open +0 value hungup \ Physical layer has disconnected + +\ Buffers +PPP_MRU PPP_HDRLEN + constant inpacket_max +inpacket_max buffer: inpacket_buf \ buffer for incoming packet +inpacket_max buffer: outpacket_buf \ buffer for outgoing packet + +0 value cip \ thumb +0 value reject_if_disagree +\ LICENSE_BEGIN +\ Copyright (c) 2006 FirmWorks +\ +\ Permission is hereby granted, free of charge, to any person obtaining +\ a copy of this software and associated documentation files (the +\ "Software"), to deal in the Software without restriction, including +\ without limitation the rights to use, copy, modify, merge, publish, +\ distribute, sublicense, and/or sell copies of the Software, and to +\ permit persons to whom the Software is furnished to do so, subject to +\ the following conditions: +\ +\ The above copyright notice and this permission notice shall be +\ included in all copies or substantial portions of the Software. +\ +\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +\ +\ LICENSE_END diff --git a/src/ofw/seechain.fth b/src/ofw/seechain.fth new file mode 100644 index 0000000..7c51895 --- /dev/null +++ b/src/ofw/seechain.fth @@ -0,0 +1,51 @@ +\ See license at end of file + +\ Recursively decompile initialization chains. +\ +\ (see-chain) ( acf -- ) +\ see-chain \ name ( -- ) + +only forth also hidden also forth definitions +headers +: (see-chain) ( acf -- ) + dup definer ['] defer = if behavior then ( acf ) + begin ( acf ) + dup definer ['] : = exit? 0= and ( acf cont? ) + while ( acf ) + dup .x dup (see) >body ( apf ) + dup token@ dup ['] (") = if ( apf acf' ) + drop ta1+ +str token@ ( acf" ) + else ( apf acf' ) + nip ( acf' ) + then ( acf"|acf' ) + repeat ( acf"|acf' ) + drop ( ) +; +: see-chain \ name ( -- ) + ' ['] (see-chain) catch if drop then +; + +only forth also definitions +\ LICENSE_BEGIN +\ Copyright (c) 2006 FirmWorks +\ +\ Permission is hereby granted, free of charge, to any person obtaining +\ a copy of this software and associated documentation files (the +\ "Software"), to deal in the Software without restriction, including +\ without limitation the rights to use, copy, modify, merge, publish, +\ distribute, sublicense, and/or sell copies of the Software, and to +\ permit persons to whom the Software is furnished to do so, subject to +\ the following conditions: +\ +\ The above copyright notice and this permission notice shall be +\ included in all copies or substantial portions of the Software. +\ +\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +\ +\ LICENSE_END |