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 present
   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 make 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 : accepted-connection ( remote local -- )
  60     [
  61         [ "remote: " % present % ", " % ]
  62         [ "local: " % present % ]
  63         bi*
  64     ] "" make
  65     \ accepted-connection NOTICE log-message ;
  66
  67 : log-connection ( remote local -- )
  68     [ accepted-connection ]
  69     [ [ remote-address set ] [ local-address set ] bi* ]
  70     2bi ;
  71
  72 M: threaded-server handle-client* handler>> call ;
  73
  74 : handle-client ( client remote local -- )
  75     '[
  76         _ _ log-connection
  77         threaded-server get
  78         [ timeout>> timeouts ] [ handle-client* ] bi
  79     ] with-stream ;
  80
  81 \ handle-client ERROR add-error-logging
  82
  83 : thread-name ( server-name addrspec -- string )
  84     unparse-short " connection from " swap 3append ;
  85
  86 : accept-connection ( threaded-server -- )
  87     [ accept ] [ addr>> ] bi
  88     [ '[ _ _ _ handle-client ] ]
  89     [ drop threaded-server get name>> swap thread-name ] 2bi
  90     spawn drop ;
  91
  92 : accept-loop ( threaded-server -- )
  93     [
  94         threaded-server get semaphore>>
  95         [ [ accept-connection ] with-semaphore ]
  96         [ accept-connection ]
  97         if*
  98     ] [ accept-loop ] bi ; inline recursive
  99
 100 : started-accept-loop ( threaded-server -- )
 101     threaded-server get
 102     [ sockets>> push ] [ ready>> raise-flag ] bi ;
 103
 104 : start-accept-loop ( addrspec -- )
 105     threaded-server get encoding>> <server>
 106     [ started-accept-loop ] [ [ accept-loop ] with-disposal ] bi ;
 107
 108 \ start-accept-loop ERROR add-error-logging
 109
 110 : init-server ( threaded-server -- threaded-server )
 111     dup semaphore>> [
 112         dup max-connections>> [
 113             <semaphore> >>semaphore
 114         ] when*
 115     ] unless ;
 116
 117 PRIVATE>
 118
 119 : start-server ( threaded-server -- )
 120     init-server
 121     dup secure-config>> [
 122         dup threaded-server [
 123             dup name>> [
 124                 [ listen-on [ start-accept-loop ] parallel-each ]
 125                 [ ready>> raise-flag ]
 126                 bi
 127             ] with-logging
 128         ] with-variable
 129     ] with-secure-context ;
 130
 131 : wait-for-server ( threaded-server -- )
 132     ready>> wait-for-flag ;
 133
 134 : start-server* ( threaded-server -- )
 135     [ [ start-server ] curry "Threaded server" spawn drop ]
 136     [ wait-for-server ]
 137     bi ;
 138
 139 : stop-server ( threaded-server -- )
 140     [ f ] change-sockets drop dispose-each ;
 141
 142 : stop-this-server ( -- )
 143     threaded-server get stop-server ;
 144
 145 GENERIC: port ( addrspec -- n )
 146
 147 M: integer port ;
 148
 149 M: object port port>> ;
 150
 151 : secure-port ( -- n )
 152     threaded-server get dup [ secure>> port ] when ;
 153
 154 : insecure-port ( -- n )
 155     threaded-server get dup [ insecure>> port ] when ;