\ This program is distributed in the hope that it will be useful,
\ but WITHOUT ANY WARRANTY; without even the implied warranty of
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
\ GNU Affero General Public License for more details.

\ You should have received a copy of the GNU Affero General Public License
\ along with this program.  If not, see <http://www.gnu.org/licenses/>.

utf-8 set-encoding

require minos2/widgets.fs

also minos

ctx 0= [IF]  window-init  [THEN]

    last->in ?dup-0=-IF  source drop  THEN
    tuck - dup IF
	\ ." text: '" forth:type ''' forth:emit forth:cr
	$, msg-text
    ELSE  2drop  THEN ;

: text-rec ( addr u -- )
    2drop ['] noop rectype-nt ;
: tag-rec ( addr u -- )
    over c@ '#' = IF
	over ?flush-text 2dup + to last->in
	[: 1 /string
	    \ ." tag: '" forth:type ''' forth:emit forth:cr
	    $, msg-tag
	;] rectype-nt
    ELSE  2drop rectype-null  THEN ;
: pk-rec ( addr u -- )
    over c@ '@' = IF  2dup 1 /string ':' -skip nick>pk
	2dup d0= IF  2drop 2drop rectype-null
	ELSE
	    2>r over ?flush-text + to last->in  2r>
	    [:
		\ ." signal: '" 85type ''' forth:emit forth:cr
		$, msg-signal
	    ;] rectype-nt
	THEN
    ELSE  2drop rectype-null  THEN ;
: chain-rec ( addr u -- )
    over c@ '!' = IF
	2dup 1 /string dup 0= IF  2drop 2drop rectype-null  EXIT  THEN
	snumber?
	case
	    0 of  endof
	    -1 of
		msg-group-o .msg:log[] $[]#
		over abs over u< IF  over 0< IF  +  ELSE  drop  THEN
		    >r over ?flush-text + to last->in  r>
		    [: msg-group-o .msg:log[] $[]@ chain, ;]
		    rectype-nt  EXIT  THEN
	    endof
	    2drop
	endcase
    THEN  2drop  rectype-null  ;
: http-rec ( addr u -- )
    2dup "https://" string-prefix? >r
    2dup "http://" string-prefix? r> or IF
	over ?flush-text 2dup + to last->in
	[: $, msg-url ;] rectype-nt
    ELSE  2drop rectype-null  THEN ;

forward hash-in

: jpeg? ( addr u -- flag )
    dup 4 - 0 max safe/string ".jpg" str= ;

		    r> free throw  THEN
	    ELSE  #0.  THEN
	    2swap file-in
	    2swap dup IF   >have+group  THEN
	    [:  dup IF  $, msg:thumbnail# ulit, msg-object  ELSE  2drop  THEN
		$, msg:image# ulit, msg-object ;]
	    r> free throw  r> to last->in ;]
	catch 0= IF  rectype-nt  EXIT  THEN  THEN
    2drop rectype-null ;
: audio-rec ( addr u -- .. token )
    2dup "audio:" string-prefix? IF
	over ?flush-text
	[:  2dup + >r
	    6 /string save-mem over >r
	    2dup [: forth:type ." .aidx" ;] $tmp file-in save-mem 2>r
	    [: forth:type ." .opus" ;] $tmp file-in save-mem 2r>
	    [:  over >r $, msg:audio-idx# ulit, msg-object r> free throw
		over >r $, msg:audio# ulit, msg-object r> free throw ;]
	    r> free throw  r> to last->in ;]
	catch 0= IF  rectype-nt  EXIT  THEN  THEN
    2drop rectype-null ;

$Variable msg-recognizer
depth >r
' text-rec ' audio-rec ' img-rec ' http-rec ' chain-rec ' tag-rec ' pk-rec
depth r> - msg-recognizer set-stack

    0 old-recs  !@ recs-backlog  >stack
    0 old-order !@ order-backlog >stack
    get-recognizers old-recs  set-stack
    also get-current context !
    get-order       old-order set-stack  previous ;
: set-net2o-cmds ( -- )
    ['] n2o >body 1 set-order
    ['] rec-nt 1 set-recognizers ;
: reset-net2o-cmds ( -- )
    old-recs  get-stack ?dup-IF  set-recognizers                 THEN
    old-order get-stack ?dup-IF  set-order definitions previous  THEN
    old-recs $free  old-order $free
    recs-backlog  stack# IF  recs-backlog  stack> old-recs  !  THEN
    order-backlog stack# IF  order-backlog stack> old-order !  THEN ;

    hash-sanitize? IF  fn-sanitize  THEN ;

\ utf8 sanitizer

: utf8-sanitize ( addr u -- )
    bounds ?DO
	I ['] xc@+ catch IF
	    [ xc-vector @ fixed-width = ] [IF] '?' [ELSE] '�' [THEN] xemit
	    drop  I I' over -
	    ['] x-size catch IF  2drop  1  THEN
	ELSE  xemit I -  THEN
    +LOOP  nothrow ;

\ config stuff