basis/io/servers/connection/connection.factor

   1 ! Copyright (C) 2003, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: continuations destructors kernel math math.parser
   4 namespaces parser sequences strings prettyprint debugger
   5 quotations combinators logging calendar assocs
   6 fry accessors arrays io io.sockets io.encodings.ascii
   7 io.sockets.secure io.files io.streams.duplex io.timeouts
   8 io.encodings threads concurrency.combinators
   9 concurrency.semaphores concurrency.flags
  10 combinators.short-circuit ;
  11 IN: io.servers.connection
  12
  13 TUPLE: threaded-server
  14 name
  15 secure insecure
  16 secure-config
  17 sockets
  18 max-connections
  19 semaphore
  20 timeout
  21 encoding
  22 handler
  23 ready ;
  24
  25 : local-server ( port -- addrspec ) "localhost" swap <inet> ;
  26
  27 : internet-server ( port -- addrspec ) f swap <inet> ;
  28
  29 : new-threaded-server ( class -- threaded-server )
  30     new
  31         "server" >>name
  32         ascii >>encoding
  33         1 minutes >>timeout
  34         V{ } clone >>sockets
  35         <secure-config> >>secure-config
  36         [ "No handler quotation" throw ] >>handler
  37         <flag> >>ready ; inline
  38
  39 : <threaded-server> ( -- threaded-server )
  40     threaded-server new-threaded-server ;
  41
  42 SYMBOL: remote-address
  43
  44 GENERIC: handle-client* ( threaded-server -- )
  45
  46 <PRIVATE
  47
  48 : >insecure ( addrspec -- addrspec' )
  49     dup { [ integer? ] [ string? ] } 1|| [ internet-server ] when ;
  50
  51 : >secure ( addrspec -- addrspec' )
  52     >insecure
  53     dup { [ secure? ] [ not ] } 1|| [ <secure> ] unless ;
  54
  55 : listen-on ( threaded-server -- addrspecs )
  56     [ secure>> >secure ] [ insecure>> >insecure ] bi
  57     [ resolve-host ] bi@ append ;
  58
  59 LOG: accepted-connection NOTICE
  60
  61 : log-connection ( remote local -- )
  62     [ [ remote-address set ] [ local-address set ] bi* ]
  63     [ 2array accepted-connection ]
  64     2bi ;
  65
  66 M: threaded-server handle-client* handler>> call ;
  67
  68 : handle-client ( client remote local -- )
  69     '[
  70         , , log-connection
  71         threaded-server get
  72         [ timeout>> timeouts ] [ handle-client* ] bi
  73     ] with-stream ;
  74
  75 : thread-name ( server-name addrspec -- string )
  76     unparse-short " connection from " swap 3append ;
  77
  78 : accept-connection ( threaded-server -- )
  79     [ accept ] [ addr>> ] bi
  80     [ '[ , , , handle-client ] ]
  81     [ drop threaded-server get name>> swap thread-name ] 2bi
  82     spawn drop ;
  83
  84 : accept-loop ( threaded-server -- )
  85     [
  86         threaded-server get semaphore>>
  87         [ [ accept-connection ] with-semaphore ]
  88         [ accept-connection ]
  89         if*
  90     ] [ accept-loop ] bi ; inline recursive
  91
  92 : started-accept-loop ( threaded-server -- )
  93     threaded-server get
  94     [ sockets>> push ] [ ready>> raise-flag ] bi ;
  95
  96 : start-accept-loop ( addrspec -- )
  97     threaded-server get encoding>> <server>
  98     [ started-accept-loop ] [ [ accept-loop ] with-disposal ] bi ;
  99
 100 \ start-accept-loop ERROR add-error-logging
 101
 102 : init-server ( threaded-server -- threaded-server )
 103     dup semaphore>> [
 104         dup max-connections>> [
 105             <semaphore> >>semaphore
 106         ] when*
 107     ] unless ;
 108
 109 PRIVATE>
 110
 111 : start-server ( threaded-server -- )
 112     init-server
 113     dup secure-config>> [
 114         dup threaded-server [
 115             dup name>> [
 116                 listen-on [
 117                     start-accept-loop
 118                 ] parallel-each
 119             ] with-logging
 120         ] with-variable
 121     ] with-secure-context ;
 122
 123 : wait-for-server ( threaded-server -- )
 124     ready>> wait-for-flag ;
 125
 126 : start-server* ( threaded-server -- )
 127     [ [ start-server ] curry "Threaded server" spawn drop ]
 128     [ wait-for-server ]
 129     bi ;
 130
 131 : stop-server ( -- )
 132     threaded-server get [ f ] change-sockets drop dispose-each ;
 133
 134 GENERIC: port ( addrspec -- n )
 135
 136 M: integer port ;
 137
 138 M: object port port>> ;
 139
 140 : secure-port ( -- n )
 141     threaded-server get dup [ secure>> port ] when ;
 142
 143 : insecure-port ( -- n )
 144     threaded-server get dup [ insecure>> port ] when ;