unmaintained/cabal/cabal.factor

   1
   2 USING: kernel
   3        io
   4        io.streams.duplex
   5        io.sockets
   6        io.server
   7        combinators continuations
   8        namespaces generic threads sequences arrays vars ;
   9
  10 IN: cabal
  11
  12 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  13
  14 TUPLE: user name ;
  15
  16 : <user> ( client -- user )
  17 user construct-empty
  18 tuck set-delegate
  19 dup [ "name: " write flush readln ] with-stream* over set-user-name ;
  20
  21 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  22
  23 VAR: users
  24
  25 : init-users ( -- ) V{ } clone >users ;
  26
  27 : show-users ( -- ) users> [ user-name print ] each flush ;
  28
  29 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  30
  31 VAR: conversation
  32
  33 : init-conversation ( -- ) V{ } clone >conversation ;
  34
  35 : show-conversation ( -- ) conversation> [ print ] each flush ;
  36
  37 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  38
  39 VARS: input user ;
  40
  41 : ((send-input)) ( other -- ) [ input> print flush ] with-stream* ;
  42
  43 : (send-input) ( other -- )
  44 [ ((send-input)) ] catch [ print dup dispose users> delete ] when ;
  45
  46 : send-input ( other -- )
  47 dup duplex-stream-closed? [ users> delete ] [ (send-input) ] if ;
  48
  49 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  50
  51 : tag-input ( -- ) user> user-name ": " input> 3append >input ;
  52
  53 : log-input ( -- ) input> conversation> push ;
  54
  55 ! : send-message ( -- ) tag-input users> >array [ send-input ] each ;
  56
  57 : send-message ( -- ) tag-input log-input users> >array [ send-input ] each ;
  58
  59 : handle-user-loop ( -- )
  60 readln >input
  61 { { [ input> f eq? ] [ user> users> delete ] }
  62   { [ input> "/log" = ] [ show-conversation handle-user-loop ] }
  63   { [ input> "/users" = ] [ show-users handle-user-loop ] }
  64   { [ t ] [ send-message handle-user-loop ] } }
  65 cond ;
  66
  67 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  68
  69 ! : handle-client ( client -- ) <user> dup users> push
  70 ! dup [ >user [ handle-user-loop ] with-stream* ] with-scope ;
  71
  72 : handle-client ( client -- )
  73 <user> dup users> push
  74 dup [ >user [ handle-user-loop ] with-stream ] with-scope ;
  75
  76 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  77
  78 : accept-client-loop ( server -- )
  79 [ accept [ handle-client ] curry in-thread ] keep
  80 accept-client-loop ;
  81
  82 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  83
  84 ! : start-cabal ( -- )
  85 ! init-users
  86 ! init-conversation
  87 ! 8000 <server> accept-client-loop ;
  88
  89 : start-cabal ( -- )
  90 init-users
  91 init-conversation
  92 8000 internet-server [ inet4? ] find nip <server> accept-client-loop ;
  93
  94 MAIN: start-cabal