/unmaintained/cryptlib/streams/streams.factor

http://github.com/abeaumont/factor · Factor · 157 lines · 118 code · 36 blank · 3 comment · 17 complexity · cb1a2cf73d047fedf687f8ab25c64475 MD5 · raw file

  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. IN: cryptlib.streams
  8. : set-attribute ( handle attribute value -- )
  9. cryptSetAttribute check-result ;
  10. : set-attribute-string ( handle attribute value -- )
  11. dup length swap string>char-alien swap
  12. cryptSetAttributeString check-result ;
  13. : default-buffer-size 64 1024 * ; inline
  14. TUPLE: crypt-stream handle eof? ;
  15. : init-crypt-stream ( handle -- )
  16. dup CRYPT_OPTION_NET_READTIMEOUT 1 set-attribute
  17. CRYPT_SESSINFO_ACTIVE 1 set-attribute ;
  18. : <crypt-stream> ( handle -- stream )
  19. dup init-crypt-stream
  20. default-buffer-size <buffer>
  21. { set-crypt-stream-handle set-delegate }
  22. crypt-stream construct
  23. dup <line-reader> swap <plain-writer> <duplex-stream> ;
  24. : check-read ( err -- eof? )
  25. {
  26. { [ dup CRYPT_ERROR_READ = ] [ drop t ] }
  27. { [ dup CRYPT_ERROR_COMPLETE = ] [ drop t ] }
  28. { [ dup CRYPT_ERROR_TIMEOUT = ] [ drop f ] }
  29. { [ t ] [ check-result f ] }
  30. } cond ;
  31. : (refill) ( stream -- err )
  32. dup [ crypt-stream-handle ] keep [ buffer@ ] keep buffer-capacity
  33. "int" <c-object> dup >r cryptPopData r> *int rot n>buffer ;
  34. : refill ( stream -- )
  35. dup (refill) check-read swap set-crypt-stream-eof? ;
  36. : read-step ( n stream -- )
  37. dup refill tuck buffer-length 2dup <=
  38. [ drop swap buffer> % ]
  39. [
  40. - swap dup buffer>> % dup crypt-stream-eof?
  41. [ 2drop ] [ read-step ] if
  42. ] if ;
  43. M: crypt-stream stream-read ( n stream -- str/f )
  44. tuck buffer-length 2dup <= [ drop swap buffer> ] [
  45. pick buffer>> [ % - swap read-step ] "" make f like
  46. ] if ;
  47. M: crypt-stream stream-read1 ( stream -- ch/f )
  48. 1 swap stream-read [ first ] [ f ] if* ;
  49. : read-until-step ( seps stream -- sep/f )
  50. dup refill 2dup buffer-until [ swap % 2nip ]
  51. [
  52. % dup crypt-stream-eof? [ 2drop f ] [ read-until-step ] if
  53. ] if* ;
  54. M: crypt-stream stream-read-until ( seps stream -- str/f sep/f )
  55. 2dup buffer-until [ >r 2nip r> ] [
  56. [ % read-until-step ] "" make f like swap
  57. ] if* ;
  58. M: crypt-stream stream-flush ( cl-stream -- )
  59. crypt-stream-handle cryptFlushData check-result ;
  60. M: crypt-stream stream-write ( str stream -- )
  61. crypt-stream-handle over string>char-alien rot length
  62. "int" <c-object> cryptPushData check-result ;
  63. M: crypt-stream stream-write1 ( ch stream -- )
  64. >r 1string r> stream-write ;
  65. : check-close ( err -- )
  66. dup CRYPT_ERROR_PARAM1 = [ drop ] [ check-result ] if ;
  67. M: crypt-stream dispose ( stream -- )
  68. crypt-stream-handle cryptDestroySession check-close ;
  69. : create-session ( format -- session )
  70. "int" <c-object> tuck CRYPT_UNUSED rot
  71. cryptCreateSession check-result *int ;
  72. : crypt-client ( server port -- handle )
  73. CRYPT_SESSION_SSL create-session
  74. [ CRYPT_SESSINFO_SERVER_PORT rot set-attribute ] keep
  75. [ CRYPT_SESSINFO_SERVER_NAME rot set-attribute-string ] keep ;
  76. : crypt-server ( port -- handle )
  77. CRYPT_SESSION_SSL_SERVER create-session
  78. [ CRYPT_SESSINFO_SERVER_PORT rot set-attribute ] keep ;
  79. : crypt-login ( handle user pass -- )
  80. swap pick CRYPT_SESSINFO_USERNAME rot set-attribute-string
  81. CRYPT_SESSINFO_PASSWORD swap set-attribute-string ;
  82. : test-server ( -- stream )
  83. init
  84. 8888 crypt-server
  85. dup "user" "pass" crypt-login
  86. <crypt-stream>
  87. "Welcome to cryptlib!" over stream-print
  88. dup stream-flush
  89. dup stream-readln print
  90. dispose
  91. end
  92. ;
  93. : test-client ( -- stream )
  94. init
  95. "localhost" 8888 crypt-client
  96. dup "user" "pass" crypt-login
  97. <crypt-stream>
  98. dup stream-readln print
  99. "Thanks!" over stream-print
  100. dup stream-flush
  101. dispose
  102. end
  103. ;
  104. : (rpl) ( stream -- stream )
  105. readln
  106. {
  107. { [ dup "." = ]
  108. [ drop dup stream-readln "READ: " write print flush (rpl) ] }
  109. { [ dup "q" = ] [ drop ] }
  110. { [ t ] [ over stream-print dup stream-flush (rpl) ] }
  111. } cond ;
  112. : test-rpl ( client? -- )
  113. ! a server where you type responses to the client manually
  114. init
  115. [ "localhost" 8888 crypt-client ] [ 8888 crypt-server ] if
  116. dup "user" "pass" crypt-login
  117. <crypt-stream>
  118. (rpl)
  119. dispose
  120. end
  121. ;