\ Сервер протокола ER22 \ Ю. Жиловец, 14.10.2004 REQUIRE " ~yz/lib/common.f " er22.log" ASCIIZ log-file-name " er22.cfg" ASCIIZ settings-file-name " services.cfg" ASCIIZ services-file-name " c:/er22.ini" ASCIIZ profile REQUIRE <( ~yz/lib/format.f REQUIRE >ORDER ~yz/lib/order.f REQUIRE DATA[ ~yz/lib/data.f REQUIRE HASH@ ~yz/lib/hash.f REQUIRE PROC: ~yz/lib/proc.f REQUIRE PARSE... ~yz/lib/parse.f REQUIRE read-profile ~yz/lib/profile.f REQUIRE RESOURCES: ~yz/lib/resources.f REQUIRE { lib/ext/locals.f REQUIRE SocketLine ~ac/lib/win/winsock/socketline2.f -5000 == err-throw \ ---------------------------- \ Глобальные параметры 1 VALUE [loglevel] 8000 VALUE [port] \ ---------------------------- \ Глобальные данные VAR logh VAR logmutex VAR server-socket VAR server-exit VAR registered VARIABLE thread-counter CREATE local-host-name 20 ALLOT CREATE catalog-host 20 ALLOT \ ---------------------------- \ Данные потоков UVAR read-sock UVAR write-sock UVAR eof? UVAR line UVAR line# UVAR data-len 3000 == args# 64 == command# 64 == servname# USER-CREATE args args# 1+ USER-ALLOT USER-CREATE command command# 1+ USER-ALLOT USER-CREATE servname servname# 1+ ALLOT \ ---------------------------- \ Протокол WINAPI: WaitForSingleObject KERNEL32.DLL WINAPI: ReleaseMutex KERNEL32.DLL : [[[ ( mutex -- ) -1 SWAP WaitForSingleObject DROP ; : ]]] ( mutex -- ) ReleaseMutex DROP ; : write-log ( z -- ) ASCIIZ> logh WRITE-FILE DROP ; : write-log-ln ( z -- ) write-log " \r\n" write-log ; WINAPI: GetLocalTime KERNEL32.DLL : write-date { \ [ 20 ] str [ 4 CELLS ] dt -- } dt GetLocalTime DROP str <(? dt 6 + W@ dt 2+ W@ dt W@ 100 MOD " ~02N.~02N.~02N " )> write-log ; : write-time { \ [ 20 ] str [ 4 CELLS ] dt -- } dt GetLocalTime DROP str <(? dt 8 + W@ dt 10 + W@ " ~02N:~02N " )> write-log ; : write-time-log ( z -- ) logmutex [[[ write-time write-log-ln logmutex ]]] ; : log ( z level -- ) [loglevel] > NOT IF write-time-log ELSE DROP THEN ; : log1 ( z -- ) 1 log ; : log2 ( z -- ) 2 log ; : log3 ( z -- ) 3 log ; : log4 ( z -- ) 4 log ; : log5 ( z -- ) 5 log ; : dlog ( z -- ) logmutex [[[ write-date write-time-log logmutex ]]] ; : dump-to-log ( excinfo --) logmutex [[[ H-STDOUT logh TO H-STDOUT SWAP EXC-DUMP1 TO H-STDOUT logmutex ]]] ; : log-error ( errcode -- ) >R <( R> DUP error-text DUP >R DUP ASCIIZ> + 2- 0 SWAP C! \ выкидываем лишний CRLF " Ошибка ~N: ~Z" )> log1 R> FREEMEM ; : ?log ( err/0 -- ) ?DUP IF log-error THEN ; \ ------------------------------------ \ Интерпретация : err-dialog ( z -- ) { \ [ 256 ] buf } buf ZMOVE <( ERR-FILE ERR-LINE# ERR-IN# buf ERR-LINE " (~S,~N:~N) ~Z: ~S" )> log1 CURFILE @ ?DUP IF FREE DROP CURFILE 0! THEN ; : include-file { filename \ depth -- } DEPTH TO depth filename ASCIIZ> ['] INCLUDED CATCH ?DUP IF PRESS PRESS \ уничтожаем остатки от INCLUDED CASE 2 3 log1 0 EXIT ENDOF -2003 OF " Неизвестное ключевое слово" ENDOF 0xC0000005 OF " Нарушение общей защиты" ENDOF -1000 OF " КОНЕЦ-МЕНЮ без МЕНЮ" ENDOF >R <( R> " Ошибка ~N" )> END-CASE err-dialog EXIT THEN DEPTH depth <> IF " Сбой стека" log1 THEN ; : parse-num ( ->bl -- n) 0. BL PARSE >NUMBER 2DROP DROP ; \ ---------------------------- \ Команды конфигурации WORDLIST == COMMANDS GET-CURRENT COMMANDS SET-CURRENT : \ [COMPILE] \ ; : # [COMPILE] \ ; : LogLevel: ( ->num) parse-num 0 MAX 5 MIN TO [loglevel] ; : Port: ( ->num) parse-num TO [port] ; SET-CURRENT \ ---------------------------- \ Возврат ошибки : write-s ( a n -- ) write-sock WriteSocket ?log ; : write ( z -- ) ASCIIZ> write-s ; : writeln ( z -- ) ASCIIZ> write-sock WriteSocketLine ?log ; : ret-error { err source descr debug debug# \ [ 2010 ] buf -- } buf <(? err " Error: ~Z" )> writeln buf <(? source " Source: ~Z" )> writeln debug IF debug# -1 = IF buf <(? debug " Debug: ~?2000Z" )> ELSE buf <(? debug debug# " Debug: ~?2000S" )> THEN writeln THEN buf <(? descr " Descr: ~Z" )> writeln " --" writeln err-throw THROW ; \ ---------------------------- \ Для внутренних сервисов : reply { z \ [ args# 1+ ] buf -- } buf <(? z " Reply: ~Z" )> writeln " --" writeln ; : reply-ok " ok" reply ; \ ---------------------------- \ Запуск внешней программы UVAR bytes-to-send : substract-bytes ( n -- ) DUP >R <( R> " Прочитано ~N байтов" )> log4 bytes-to-send SWAP - TO bytes-to-send ; : write-stdin ( addr # h -- ior ) OVER substract-bytes WRITE-FILE ; : bytes-remained ( n -- ) bytes-to-send MIN ; : pipe-stdin { write-end \ [ 500 ] buf -- } data-len 0= IF EXIT THEN read-sock SocketGetPending bytes-remained write-end write-stdin IF EXIT THEN BEGIN bytes-to-send 0= IF EXIT THEN buf 500 bytes-remained read-sock sl_socket @ ReadSocket IF DROP EXIT THEN buf SWAP write-end write-stdin IF EXIT THEN AGAIN ; \ Ввод-вывод в этом слове сознательно сделан \ последовательным. \ Внешняя программа ОБЯЗАНА сначала прочитать все свои данные \ или закрыть STDIN, если она не желает их читать, \ и лишь потом выводить результат : PIPE-DATA { write-end read-end \ [ 500 ] buf -- } \ передаем программе присланные данные <( data-len " Подлежит пересылке ~N байтов" )> log4 data-len TO bytes-to-send write-end pipe-stdin \ пересылаем вывод от программы BEGIN buf 500 read-end READ-FILE 0= WHILE ( bytesread) buf SWAP write-sock WriteSocket ?log REPEAT DROP ; WINAPI: CreatePipe KERNEL32.DLL WINAPI: CreateProcessA KERNEL32.DLL : inheritable-pipe { \ read write -- write-end read-end} 0 DATA[ 3 CELLS , 0 , 1 , ]DATA ^ write ^ read CreatePipe 0= IF " cannot-run" " server" " Не могу запустить процесс" S" CreatePipe" ret-error THEN write read ; : make-environment ( env -- env ) <(? args command data-len " Args=~Z~.Command=~Z~.Data=~N~.~." )> ; : run-program { command \ read-of-stdin write-of-stdin read-of-stdout write-of-stdout [ 4 CELLS ] pinfo [ 18 CELLS ] startup [ args# command# + 30 + ] env [ 520 ] cmdstr } command cmdstr ZMOVE <( cmdstr " Запуск: ~Z" )> log3 \ Создание каналов inheritable-pipe TO read-of-stdin TO write-of-stdin inheritable-pipe TO read-of-stdout TO write-of-stdout \ Параметры запускаемой программы startup init->> 18 CELLS >> \ length of record 0 >> \ reserved 0 >> \ desktop 0 >> \ title 7 zeroes>> \ some console and windows attributes 257 >> \ flags: startf_usedesthandles startf_useshowwindow 0 W>> \ window: sw_hide 0 W>> \ reserved 0 >> \ reserved read-of-stdin >> \ stdin write-of-stdout DUP >> \ stdout >> \ stderr \ Вызов программы pinfo \ process info startup \ startup info 0 \ current directory env make-environment \ environment 0 \ flags TRUE \ inherit handles 0 0 \ security attributes cmdstr \ command line 0 \ application CreateProcessA \ закрываем ненужные дескрипторы потоков - их копии \ уже переданы дочернему процесуу read-of-stdin CloseHandle DROP write-of-stdout CloseHandle DROP DUP IF \ -- процесс запущен \ закрываем дескрипторы процесса и его главного потока pinfo @ CloseHandle DROP pinfo 1 CELLS@ CloseHandle DROP \ перекачиваем данные write-of-stdin read-of-stdout PIPE-DATA THEN \ закрываем оставшиеся дескрипторы потоков read-of-stdout CloseHandle DROP write-of-stdin CloseHandle DROP 0= IF \ -- ошибка при запуске " cannot-run" " server" " Не могу запустить процесс" cmdstr -1 ret-error THEN ; \ ---------------------------- \ Словарь сервисов WORDLIST == SERVICES \ ------------------------------ \ Настройка сервисов : ((( ( -- current) GET-CURRENT SERVICES SET-CURRENT ; : ))) ( current -- ) SET-CURRENT ; : land-str ( a n -- a1 ) DUP >R HERE CZMOVE R> 1+ ALLOT ; : Internal: ( ->eol; -- oldwid ) ((( : ; : Internal; ( oldwid -- ) [COMPILE] ; ))) ; IMMEDIATE : compile-cmdstr ( -- ) HERE CELL+ , 13 PARSE land-str ; : run-does ( a -- ) DOES> @ run-program ; : Run: ( ->bl:name ->eol:cmdstr) ((( CREATE compile-cmdstr run-does ))) ; : compile-script-does DOES> >R <( R> DUP @ SWAP 1 CELLS@ " ~Z ~Z" )> run-program ; : compile-script ( prog -- ) ((( SWAP CREATE , compile-cmdstr compile-script-does ))) ; : script-does DOES> @ compile-script ; : Script: ( ->bl:name ->eol:cmdstr) CREATE compile-cmdstr script-does ; \ ---------------------------- \ Команды протокола WORDLIST == PROTOCOL GET-CURRENT PROTOCOL SET-CURRENT : Data: ( ->num) parse-num 0 MAX TO data-len ; : Service: ( ->bl) 13 PARSE servname# MIN servname CZMOVE ; : Args: ( ->eol) 13 PARSE args# MIN args CZMOVE ; : Command: ( ->eol) 13 PARSE command# MIN command CZMOVE ; : -- ( -- ) servname C@ 0= IF " no-service" " server" " Не указано имя сервиса" 0 0 ret-error THEN servname ASCIIZ> SERVICES SEARCH-WORDLIST IF EXECUTE ELSE " bad-service" " server" " Неправильное имя сервиса" servname -1 ret-error THEN TRUE TO eof? ; SET-CURRENT \ ---------------------------- \ Серверный поток : eval-string ( -- ) <( line line# " \'~S\'" )> log3 line line# ['] EVALUATE CATCH ?DUP IF CASE -2003 OF " bad-keyword" " server" " Неизвестное ключевое слово в запросе" line line# ret-error ENDOF err-throw OF TRUE TO eof? \ произошла ошибка при обработке - прервать разбор запроса ENDOF >R " interr" " server" " Внутренняя ошибка сервера" <( R> DUP " ~N (0x~08H)" )> -1 ret-error END-CASE 2DROP THEN ; : process-request PROTOCOL 1 SET-ORDER 0 TO data-len command 0! args 0! BEGIN \ читаем из входного сокета и в случае любой ошибки чтения \ (например, клиент разорвал соединение) прекращаем интерпретацию eof? IF EXIT THEN read-sock ['] SocketReadLine CATCH ?DUP IF log-error DROP EXIT THEN TO line# TO line eval-string AGAIN ; : log-request ( -- ) write-sock GetPeerIP&Port ?log DROP >R <( R> inet_ntoa write-sock GetPeerName IF 2DROP S" ???" THEN " Запрос от ~Z (~S)" )> log2 ; WINAPI: InterlockedIncrement KERNEL32.DLL WINAPI: InterlockedDecrement KERNEL32.DLL :NONAME ( socket --) thread-counter InterlockedIncrement >R <( R> " Поток запущен. Счетчик: ~N" )> log4 DUP TO write-sock SocketLine TO read-sock log-request ['] process-request CATCH CASE 0 OF ENDOF err-throw OF \ практически нормальный возврат - \ обработчик сигнализирует об ошибке ENDOF \ случаи, которых вообще не должно быть log-error END-CASE write-sock CloseSocket ?log thread-counter InterlockedDecrement >R <( R> " Поток остановлен. Счетчик: ~N" )> log4 ; TASK: REQUEST \ ---------------------------- \ Служба каталогов : register-service ( aserv nserv awhere nwhere -- ) 2SWAP registered HASH! ; : get-registered ( aserv #serv -- awhere nwhere) ASCIIZ> registered HASH@ ; : ?empty-arg args C@ 0= IF " no-args" " catalog" " Пропущены аргументы вызова" 0 0 ret-error THEN ; : catalog-add ?empty-arg args PARSE... c: , PARSE 13 PARSE register-service ...PARSE reply-ok ; : catalog-del ?empty-arg args ASCIIZ> registered HASH? IF args ASCIIZ> registered -HASH reply-ok ELSE " serv-not-reg" " catalog" " Служба не зарегистрирована" args -1 ret-error THEN ; UVAR comma PROC: write-catalog ( akey nkey value -- ) comma IF " ," write ELSE TRUE TO comma THEN -ROT write-s " ," write COUNT write-s PROC; : catalog-list " Reply: " write FALSE TO comma write-catalog registered all-hash "" writeln " --" writeln ; : catalog-service command CASE DUP " add" ZCOMPARE 0= =OF catalog-add ENDOF DUP " del" ZCOMPARE 0= =OF catalog-del ENDOF DUP " list" ZCOMPARE 0= =OF catalog-list ENDOF " bad-command" " catalog" " Неизвестная команда" command -1 ret-error END-CASE ; \ ---------------------------- \ Вызов сервера UVAR s UVAR sl : (ServerCall) { host port res query \ [ args# 1+ ] str -- } catalog-host ASCIIZ> GetHostIP THROW CreateSocket THROW TO s s SocketLine TO sl port s ConnectSocket THROW query ASCIIZ> s WriteSocket THROW " --\13\10" ASCIIZ> s WriteSocket THROW BEGIN sl SocketReadLine 2DUP S" --" COMPARE WHILE SPARSE... c: : PARSE 30 MIN BL SKIP 13 PARSE args# MIN str CZMOVE str -ROT res HASH!Z ...PARSE REPEAT 2DROP ; : ServerCall ( host port res query -- ior ) 0 TO s 0 TO sl ['] (ServerCall) CATCH DUP IF >R 2DROP 2DROP R> THEN sl ?DUP IF FREEMEM THEN s ?DUP IF CloseSocket DROP THEN ; \ ---------------------------- \ Регистрация в службе каталогов : get-catalog ( z -- ?) >R " global" " catalog" R@ read-profile R> " ?" ZCOMPARE ; : traverse-wordlist { wordlist xt -- } wordlist @ BEGIN ?DUP WHILE DUP COUNT xt EXECUTE CDR REPEAT ; PROC: reg-service ( aword nword -- ) local-host-name ASCIIZ> register-service PROC; : register-services-in-local SERVICES reg-service traverse-wordlist ; PROC: remote-reg { aword nword -- } catalog-host [port] small-hash DUP >R <( aword nword local-host-name " Service: catalog~/Command: add~/Args: ~S,~Z~/" )> ServerCall ?DUP IF log-error ELSE S" Error" R@ HASH? IF <( catalog-host [port] S" Error" R@ HASH@Z S" Descr" R@ HASH@Z " Регистрация неудачна: сервер ~Z:~N, ошибка ~'~Z~': ~Z" )> log1 THEN THEN R> del-hash PROC; : register-services-on-remote SERVICES remote-reg traverse-wordlist ; : does-call-catalog DOES> DROP catalog-service ; : run-local-catalog GET-CURRENT SERVICES SET-CURRENT S" catalog" CREATED does-call-catalog SET-CURRENT ; : register-in-catalog catalog-host get-catalog 0= IF <( profile " Файл ~'~Z~' отсутствует или не содержит информации о службе каталогов" )> log1 EXIT THEN catalog-host " localhost" ZCOMPARE 0= IF run-local-catalog register-services-in-local ELSE register-services-on-remote THEN ; : ask-local-host 0 GetHostName ?log local-host-name CZMOVE ; \ ---------------------------- \ Инициализация WINAPI: CreateMutexA KERNEL32.DLL : initialize log-file-name ASCIIZ> 2DUP FILE-EXIST IF W/O OPEN-FILE-SHARED ELSE W/O CREATE-FILE-SHARED THEN IF ." Не могу открыть файл протокола" BYE THEN TO logh \ переставляем указатель в конец файла logh FILE-SIZE DROP logh REPOSITION-FILE DROP 0 0 0 CreateMutexA TO logmutex SocketsStartup ?log 0 thread-counter ! small-hash TO registered ; : cleanup registered del-hash SocketsCleanup ?log logmutex CloseHandle DROP logh CLOSE-FILE DROP ; \ --------------------------------- : accept-connections ( -- ) BEGIN server-exit IF EXIT THEN server-socket AcceptSocketNotBlock ( -- s ior) ?DUP IF DUP 10060 = IF DROP \ просто не поступило соединения ELSE log-error THEN DROP ELSE REQUEST START 0= IF " Не могу запустить поток" log1 THEN THEN AGAIN ; WINAPI: InterlockedExchangeAdd KERNEL32.DLL : wait-all-threads BEGIN 0 thread-counter InterlockedExchangeAdd WHILE 500 PAUSE REPEAT ; : run-server ( -- ) [port] ['] CreateServerSocket CATCH ?DUP IF DUP 10048 = IF DROP <( [port] " На порту ~N уже работает другой сервер" )> log1 ELSE log-error THEN DROP EXIT THEN TO server-socket accept-connections wait-all-threads server-socket CloseSocket ?log ; : ER22 ['] dump-to-log TO initialize " Сервер запущен" dlog GET-ORDER COMMANDS 1 SET-ORDER settings-file-name include-file SET-ORDER services-file-name include-file ask-local-host register-in-catalog run-server " Сервер остановлен" dlog "" write-log-ln cleanup BYE ; \ --------------------------------- 0 TO SPF-INIT? \ ' ANSI>OEM TO ANSI>