unmaintained/cryptlib/streams/streams.factor

   1 ! Copyright (C) 2007 Matthew Willis
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: cryptlib cryptlib.libcl kernel alien sequences continuations
   4 byte-arrays namespaces io.buffers math generic io strings
   5 io.streams.lines io.streams.plain io.streams.duplex combinators
   6 alien.c-types continuations ;
   7
   8 IN: 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
  19 TUPLE: 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
  55 M: 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
  60 M: 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
  69 M: 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
  74 M: crypt-stream stream-flush ( cl-stream -- )
  75     crypt-stream-handle cryptFlushData check-result ;
  76
  77 M: crypt-stream stream-write ( str stream -- )
  78     crypt-stream-handle over string>char-alien rot length
  79     "int" <c-object> cryptPushData check-result ;
  80
  81 M: 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
  87 M: 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     ;