! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: continuations destructors kernel math math.parser
namespaces parser sequences strings prettyprint debugger
quotations combinators logging calendar assocs present
fry accessors arrays io io.sockets io.encodings.ascii
io.sockets.secure io.files io.streams.duplex io.timeouts
io.encodings threads make concurrency.combinators
concurrency.semaphores concurrency.flags
combinators.short-circuit ;
IN: io.servers.connection

TUPLE: threaded-server
name
secure insecure
secure-config
sockets
max-connections
semaphore
timeout
encoding
handler
ready ;

: local-server ( port -- addrspec ) "localhost" swap <inet> ;

: internet-server ( port -- addrspec ) f swap <inet> ;

: new-threaded-server ( class -- threaded-server )
    new
        "server" >>name
        ascii >>encoding
        1 minutes >>timeout
        V{ } clone >>sockets
        <secure-config> >>secure-config
        [ "No handler quotation" throw ] >>handler
        <flag> >>ready ; inline

: <threaded-server> ( -- threaded-server )
    threaded-server new-threaded-server ;

SYMBOL: remote-address

GENERIC: handle-client* ( threaded-server -- )

<PRIVATE

: >insecure ( addrspec -- addrspec' )
    dup { [ integer? ] [ string? ] } 1|| [ internet-server ] when ;

: >secure ( addrspec -- addrspec' )
    >insecure
    dup { [ secure? ] [ not ] } 1|| [ <secure> ] unless ;

: listen-on ( threaded-server -- addrspecs )
    [ secure>> >secure ] [ insecure>> >insecure ] bi
    [ resolve-host ] bi@ append ;

: accepted-connection ( remote local -- )
    [
        [ "remote: " % present % ", " % ]
        [ "local: " % present % ]
        bi*
    ] "" make
    \ accepted-connection NOTICE log-message ;

: log-connection ( remote local -- )
    [ accepted-connection ]
    [ [ remote-address set ] [ local-address set ] bi* ]
    2bi ;

M: threaded-server handle-client* handler>> call ;

: handle-client ( client remote local -- )
    '[
        _ _ log-connection
        threaded-server get
        [ timeout>> timeouts ] [ handle-client* ] bi
    ] with-stream ;

\ handle-client ERROR add-error-logging

: thread-name ( server-name addrspec -- string )
    unparse-short " connection from " swap 3append ;

: accept-connection ( threaded-server -- )
    [ accept ] [ addr>> ] bi
    [ '[ _ _ _ handle-client ] ]
    [ drop threaded-server get name>> swap thread-name ] 2bi
    spawn drop ;

: accept-loop ( threaded-server -- )
    [
        threaded-server get semaphore>>
        [ [ accept-connection ] with-semaphore ]
        [ accept-connection ]
        if*
    ] [ accept-loop ] bi ; inline recursive

: started-accept-loop ( threaded-server -- )
    threaded-server get
    [ sockets>> push ] [ ready>> raise-flag ] bi ;

: start-accept-loop ( addrspec -- )
    threaded-server get encoding>> <server>
    [ started-accept-loop ] [ [ accept-loop ] with-disposal ] bi ;

\ start-accept-loop NOTICE add-error-logging

: init-server ( threaded-server -- threaded-server )
    dup semaphore>> [
        dup max-connections>> [
            <semaphore> >>semaphore
        ] when*
    ] unless ;

PRIVATE>

: start-server ( threaded-server -- )
    init-server
    dup secure-config>> [
        dup threaded-server [
            dup name>> [
                [ listen-on [ start-accept-loop ] parallel-each ]
                [ ready>> raise-flag ]
                bi
            ] with-logging
        ] with-variable
    ] with-secure-context ;

: wait-for-server ( threaded-server -- )
    ready>> wait-for-flag ;

: start-server* ( threaded-server -- )
    [ [ start-server ] curry "Threaded server" spawn drop ]
    [ wait-for-server ]
    bi ;

: stop-server ( threaded-server -- )
    [ f ] change-sockets drop dispose-each ;

: stop-this-server ( -- )
    threaded-server get stop-server ;

GENERIC: port ( addrspec -- n )

M: integer port ;

M: object port port>> ;

: secure-port ( -- n )
    threaded-server get dup [ secure>> port ] when ;

: insecure-port ( -- n )
    threaded-server get dup [ insecure>> port ] when ;