basis/io/servers/connection/connection.factor

   1 ! Copyright (C) 2003, 2009 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
   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 call ;
  11 IN: io.servers.connection
  12
  13 TUPLE: threaded-server
  14 name
  15 log-level
  16 secure insecure
  17 secure-config
  18 sockets
  19 max-connections
  20 semaphore
  21 timeout
  22 encoding
  23 handler
  24 ready ;
  25
  26 : local-server ( port -- addrspec ) "localhost" swap <inet> ;
  27
  28 : internet-server ( port -- addrspec ) f swap <inet> ;
  29
  30 : new-threaded-server ( class -- threaded-server )
  31     new
  32         "server" >>name
  33         DEBUG >>log-level
  34         ascii >>encoding
  35         1 minutes >>timeout
  36         V{ } clone >>sockets
  37         <secure-config> >>secure-config
  38         [ "No handler quotation" throw ] >>handler
  39         <flag> >>ready ; inline
  40
  41 : <threaded-server> ( -- threaded-server )
  42     threaded-server new-threaded-server ;
  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 " glue ;
  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 NOTICE 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 : (start-server) ( threaded-server -- )
 118     init-server
 119     dup threaded-server [
 120         [ ] [ name>> ] bi [
 121             [ listen-on [ start-accept-loop ] parallel-each ]
 122             [ ready>> raise-flag ]
 123             bi
 124         ] with-logging
 125     ] with-variable ;
 126
 127 PRIVATE>
 128
 129 : start-server ( threaded-server -- )
 130     #! Only create a secure-context if we want to listen on
 131     #! a secure port, otherwise start-server won't work at
 132     #! all if SSL is not available.
 133     dup secure>> [
 134         dup secure-config>> [
 135             (start-server)
 136         ] with-secure-context
 137     ] [
 138         (start-server)
 139     ] if ;
 140
 141 : wait-for-server ( threaded-server -- )
 142     ready>> wait-for-flag ;
 143
 144 : start-server* ( threaded-server -- )
 145     [ [ start-server ] curry "Threaded server" spawn drop ]
 146     [ wait-for-server ]
 147     bi ;
 148
 149 : stop-server ( threaded-server -- )
 150     [ f ] change-sockets drop dispose-each ;
 151
 152 : stop-this-server ( -- )
 153     threaded-server get stop-server ;
 154
 155 GENERIC: port ( addrspec -- n )
 156
 157 M: integer port ;
 158
 159 M: object port port>> ;
 160
 161 : secure-port ( -- n )
 162     threaded-server get dup [ secure>> port ] when ;
 163
 164 : insecure-port ( -- n )
 165     threaded-server get dup [ insecure>> port ] when ;