extra/broadcast-server/broadcast-server.factor

   1 ! Copyright (C) 2021 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs calendar combinators
   4 combinators.extras continuations destructors io
   5 io.encodings.string io.encodings.utf8 io.files.info io.sockets
   6 io.streams.string kernel layouts make parser prettyprint
   7 prettyprint.config sequences splitting system system-info
   8 threads ;
   9 IN: broadcast-server
  10
  11 TUPLE: broadcast-server < disposable
  12     broadcast-inet4
  13     receive-inet4
  14     should-stop?
  15     received
  16     broadcast-socket
  17     receive-socket ;
  18
  19 : <broadcast-server> ( broadcast-ip port -- obj )
  20     broadcast-server new-disposable
  21         over f swap <inet4> >>receive-inet4
  22         -rot <inet4> >>broadcast-inet4
  23         H{ } clone >>received ; inline
  24
  25 M: broadcast-server dispose*
  26     [ receive-socket>> dispose ]
  27     [ broadcast-socket>> dispose ] bi ;
  28
  29 : broadcast-server-send ( bytes type broadcast-server -- )
  30     [ 2array unparse utf8 encode ] dip
  31     [ broadcast-inet4>> ] [ broadcast-socket>> ] bi send ;
  32
  33 SINGLETONS: command data ;
  34
  35 : send-broadcast-command ( str server -- )
  36     [ command ] dip broadcast-server-send ;
  37
  38 : send-broadcast-data ( str server -- )
  39     [ data ] dip broadcast-server-send ;
  40
  41 : run-command ( string -- out )
  42     [ parse-lines [ [ call( -- ) ] with-string-writer ] without-limits ]
  43     [ drop ] recover ;
  44
  45 : handle-data ( data inet4 broadcast-server -- )
  46     [ received>> push-at ]
  47     [
  48         [ . ] dip
  49         swap dup ...
  50         first
  51         unclip-last {
  52             { data [ 2drop ] }
  53             { command [ run-command swap send-broadcast-data ] }
  54             [ unparse "unknown command: " prepend print 2drop ]
  55         } case
  56         nl
  57     ] 3bi ;
  58
  59 : receive-loop ( broadcast-server -- )
  60     '[
  61         [
  62             _ dup should-stop?>> [
  63                 dispose f
  64             ] [
  65                 [
  66                     receive-socket>> receive
  67                     [ utf8 decode "\n" split parse-lines ] dip
  68                 ] keep handle-data t
  69             ] if
  70         ] loop
  71     ] in-thread ;
  72
  73 : payload ( -- byte-array )
  74     [
  75         computer-name "computer-name" ,,
  76         os unparse "os" ,,
  77         os-version "os-version" ,,
  78         cpu unparse "cpu" ,,
  79         cell-bits "cell-bits" ,,
  80         username "username" ,,
  81
  82         build "build" ,,
  83         vm-git-id "git-id" ,,
  84         version-info "version-info" ,,
  85         vm-path "vm-path" ,,
  86         vm-path file-info size>> "vm-size" ,,
  87         image-path "image-path" ,,
  88         image-path file-info size>> "image-size" ,,
  89
  90         cpus "cpus" ,,
  91         cpu-mhz "cpu-mhz" ,,
  92         physical-mem "physical-mem" ,,
  93         vm-path file-system-info
  94         [ total-space>> "disk-total-size" ,, ]
  95         [ free-space>> "disk-free-size" ,, ] bi
  96     ] { } make ;
  97
  98 : send-loop ( broadcast-server -- )
  99     '[
 100         [
 101             _ dup should-stop?>> [
 102                 dispose f
 103             ] [
 104                 payload data rot broadcast-server-send t
 105             ] if
 106             3 seconds sleep
 107         ] loop
 108     ] in-thread ;
 109
 110 : start-broadcast-server ( ip port -- obj )
 111     [
 112         <broadcast-server>
 113             dup receive-inet4>> <datagram> |dispose >>receive-socket
 114             dup broadcast-inet4>> <any-port-local-broadcast> |dispose >>broadcast-socket
 115         [ receive-loop ]
 116         [ send-loop ]
 117         [ ] tri
 118     ] with-destructors ;
 119
 120 ! "192.168.88.255" 7777 start-broadcast-server
 121 ! "USE: math 2 2 + ." over send-broadcast-command