/unmaintained/cryptlib/streams/streams.factor

  1! Copyright (C) 2007 Matthew Willis
  2! See http://factorcode.org/license.txt for BSD license.
  3USING: cryptlib cryptlib.libcl kernel alien sequences continuations
  4byte-arrays namespaces io.buffers math generic io strings
  5io.streams.lines io.streams.plain io.streams.duplex combinators
  6alien.c-types continuations ;
  7
  8IN: cryptlib.streams
  9
 10: set-attribute ( handle attribute value -- )
 11    cryptSetAttribute check-result ;
 12
 13: set-attribute-string ( handle attribute value -- )
 14    dup length swap string>char-alien swap
 15    cryptSetAttributeString check-result ;
 16
 17: default-buffer-size 64 1024 * ; inline
 18
 19TUPLE: crypt-stream handle eof? ;
 20
 21: init-crypt-stream ( handle -- )
 22    dup CRYPT_OPTION_NET_READTIMEOUT 1 set-attribute
 23    CRYPT_SESSINFO_ACTIVE 1 set-attribute ;
 24
 25: <crypt-stream> ( handle -- stream )
 26    dup init-crypt-stream
 27    default-buffer-size <buffer>
 28    { set-crypt-stream-handle set-delegate }
 29    crypt-stream construct
 30    dup <line-reader> swap <plain-writer> <duplex-stream> ;
 31
 32: check-read ( err -- eof? )
 33    {
 34        { [ dup CRYPT_ERROR_READ = ] [ drop t ] }
 35        { [ dup CRYPT_ERROR_COMPLETE = ] [ drop t ] }
 36        { [ dup CRYPT_ERROR_TIMEOUT = ] [ drop f ] }
 37        { [ t ] [ check-result f ] }
 38    } cond ;
 39
 40: (refill) ( stream -- err )
 41    dup [ crypt-stream-handle ] keep [ buffer@ ] keep buffer-capacity
 42    "int" <c-object> dup >r cryptPopData r> *int rot n>buffer ;
 43
 44: refill ( stream -- )
 45    dup (refill) check-read swap set-crypt-stream-eof? ;
 46
 47: read-step ( n stream -- )
 48    dup refill tuck buffer-length 2dup <= 
 49    [ drop swap buffer> % ]
 50    [
 51        - swap dup buffer>> % dup crypt-stream-eof? 
 52        [ 2drop ] [ read-step ] if
 53    ] if ;
 54
 55M: crypt-stream stream-read ( n stream -- str/f )
 56    tuck buffer-length 2dup <= [ drop swap buffer> ] [
 57        pick buffer>> [ % - swap read-step ] "" make f like
 58    ] if ;
 59
 60M: crypt-stream stream-read1 ( stream -- ch/f )
 61    1 swap stream-read [ first ] [ f ] if* ;
 62
 63: read-until-step ( seps stream -- sep/f )
 64    dup refill 2dup buffer-until [ swap % 2nip ]
 65    [ 
 66        % dup crypt-stream-eof? [ 2drop f ] [ read-until-step ] if
 67    ] if* ;
 68
 69M: crypt-stream stream-read-until ( seps stream -- str/f sep/f )
 70    2dup buffer-until [ >r 2nip r> ] [
 71        [ % read-until-step ] "" make f like swap
 72    ] if* ;
 73 
 74M: crypt-stream stream-flush ( cl-stream -- )
 75    crypt-stream-handle cryptFlushData check-result ;
 76
 77M: crypt-stream stream-write ( str stream -- )
 78    crypt-stream-handle over string>char-alien rot length
 79    "int" <c-object> cryptPushData check-result ;
 80
 81M: crypt-stream stream-write1 ( ch stream -- )
 82    >r 1string r> stream-write ;
 83
 84: check-close ( err -- )
 85    dup CRYPT_ERROR_PARAM1 = [ drop ] [ check-result ] if ;
 86    
 87M: crypt-stream dispose ( stream -- )
 88    crypt-stream-handle cryptDestroySession check-close ;
 89
 90: create-session ( format -- session )
 91    "int" <c-object> tuck CRYPT_UNUSED rot
 92    cryptCreateSession check-result *int ;
 93
 94: crypt-client ( server port -- handle )
 95    CRYPT_SESSION_SSL create-session
 96    [ CRYPT_SESSINFO_SERVER_PORT rot set-attribute ] keep
 97    [ CRYPT_SESSINFO_SERVER_NAME rot set-attribute-string ] keep ;
 98
 99: crypt-server ( port -- handle )
100    CRYPT_SESSION_SSL_SERVER create-session
101    [ CRYPT_SESSINFO_SERVER_PORT rot set-attribute ] keep ;
102
103: crypt-login ( handle user pass -- )
104    swap pick CRYPT_SESSINFO_USERNAME rot set-attribute-string
105    CRYPT_SESSINFO_PASSWORD swap set-attribute-string ;
106
107: test-server ( -- stream )
108    init
109    8888 crypt-server
110    dup "user" "pass" crypt-login
111    <crypt-stream>
112    
113    "Welcome to cryptlib!" over stream-print 
114    dup stream-flush
115    
116    dup stream-readln print
117    
118    dispose 
119    end 
120    ;
121    
122: test-client ( -- stream )
123    init
124    "localhost" 8888 crypt-client
125    dup "user" "pass" crypt-login
126    <crypt-stream>
127    
128    dup stream-readln print
129    
130    "Thanks!" over stream-print
131    dup stream-flush
132    
133    dispose
134    end 
135    ;
136    
137: (rpl) ( stream -- stream )
138    readln
139    {
140        { [ dup "." = ] 
141            [ drop dup stream-readln "READ: " write print flush (rpl) ] }
142        { [ dup "q" = ] [ drop ] }
143        { [ t ] [ over stream-print dup stream-flush (rpl) ] }
144    } cond ;
145
146: test-rpl ( client? -- )
147    ! a server where you type responses to the client manually
148    init
149    [ "localhost" 8888 crypt-client ] [ 8888 crypt-server ] if
150    dup "user" "pass" crypt-login
151    <crypt-stream>
152    
153    (rpl)
154    
155    dispose 
156    end 
157    ;