clic/3rdparties/software/cl+ssl-20200427-git/src/bio.lisp

3rdparties/software/cl+ssl-20200427-git/src/bio.lisp (4236 bytes)
1 ;;;; -*- Mode: LISP; Syntax: COMMON-LISP; indent-tabs-mode: nil; coding: utf-8; show-trailing-whitespace: t -*-
2 ;;;
3 ;;; Copyright (C) 2005  David Lichteblau
4 ;;;
5 ;;; See LICENSE for details.
6 
7 #+xcvb (module (:depends-on ("package")))
8 
9 (in-package cl+ssl)
10 
11 (defconstant +bio-type-socket+ (logior 5 #x0400 #x0100))
12 (defconstant +BIO_FLAGS_READ+ 1)
13 (defconstant +BIO_FLAGS_WRITE+ 2)
14 (defconstant +BIO_FLAGS_SHOULD_RETRY+ 8)
15 (defconstant +BIO_CTRL_FLUSH+ 11)
16 
17 (cffi:defcstruct bio-method
18   (type :int)
19   (name :pointer)
20   (bwrite :pointer)
21   (bread :pointer)
22   (bputs :pointer)
23   (bgets :pointer)
24   (ctrl :pointer)
25   (create :pointer)
26   (destroy :pointer)
27   (callback-ctrl :pointer))
28 
29 (cffi:defcstruct bio
30   (method :pointer)
31   (callback :pointer)
32   (cb-arg :pointer)
33   (init :int)
34   (shutdown :int)
35   (flags :int)
36   (retry-reason :int)
37   (num :int)
38   (ptr :pointer)
39   (next-bio :pointer)
40   (prev-bio :pointer)
41   (references :int)
42   (num-read :unsigned-long)
43   (num-write :unsigned-long)
44   (crypto-ex-data-stack :pointer)
45   (crypto-ex-data-dummy :int))
46 
47 (defun make-bio-lisp-method ()
48   (let ((m (cffi:foreign-alloc '(:struct bio-method))))
49     (setf (cffi:foreign-slot-value m '(:struct bio-method) 'type)
50     ;; fixme: this is wrong, but presumably still better than some
51     ;; random value here.
52     +bio-type-socket+)
53     (macrolet ((slot (name)
54      `(cffi:foreign-slot-value m '(:struct bio-method) ,name)))
55       (setf (slot 'name) (cffi:foreign-string-alloc "lisp"))
56       (setf (slot 'bwrite) (cffi:callback lisp-write))
57       (setf (slot 'bread) (cffi:callback lisp-read))
58       (setf (slot 'bputs) (cffi:callback lisp-puts))
59       (setf (slot 'bgets) (cffi:null-pointer))
60       (setf (slot 'ctrl) (cffi:callback lisp-ctrl))
61       (setf (slot 'create) (cffi:callback lisp-create))
62       (setf (slot 'destroy) (cffi:callback lisp-destroy))
63       (setf (slot 'callback-ctrl) (cffi:null-pointer)))
64     m))
65 
66 (defun bio-new-lisp ()
67   (bio-new *bio-lisp-method*))
68 
69 
70 ;;; "cargo cult"
71 
72 (cffi:defcallback lisp-write :int ((bio :pointer) (buf :pointer) (n :int))
73   bio
74   (dotimes (i n)
75     (write-byte (cffi:mem-ref buf :unsigned-char i) *socket*))
76   (finish-output *socket*)
77   n)
78 
79 (defun clear-retry-flags (bio)
80   (setf (cffi:foreign-slot-value bio '(:struct bio) 'flags)
81   (logandc2 (cffi:foreign-slot-value bio '(:struct bio) 'flags)
82       (logior +BIO_FLAGS_READ+
83         +BIO_FLAGS_WRITE+
84         +BIO_FLAGS_SHOULD_RETRY+))))
85 
86 (defun set-retry-read (bio)
87   (setf (cffi:foreign-slot-value bio '(:struct bio) 'flags)
88   (logior (cffi:foreign-slot-value bio '(:struct bio) 'flags)
89     +BIO_FLAGS_READ+
90     +BIO_FLAGS_SHOULD_RETRY+)))
91 
92 (cffi:defcallback lisp-read :int ((bio :pointer) (buf :pointer) (n :int))
93   bio buf n
94   (let ((i 0))
95     (handler-case
96   (unless (or (cffi:null-pointer-p buf) (null n))
97     (clear-retry-flags bio)
98     (when (or *blockp* (listen *socket*))
99             (setf (cffi:mem-ref buf :unsigned-char i) (read-byte *socket*))
100             (incf i))
101     (loop
102         while (and (< i n)
103                          (or (null *partial-read-p*) (listen *socket*)))
104         do
105     (setf (cffi:mem-ref buf :unsigned-char i) (read-byte *socket*))
106     (incf i))
107     #+(or)
108     (when (zerop i) (set-retry-read bio)))
109       (end-of-file ()))
110     i))
111 
112 (cffi:defcallback lisp-puts :int ((bio :pointer) (buf :string))
113   bio buf
114   (error "lisp-puts not implemented"))
115 
116 (cffi:defcallback lisp-ctrl :int
117   ((bio :pointer) (cmd :int) (larg :long) (parg :pointer))
118   bio larg parg
119   (cond
120     ((eql cmd +BIO_CTRL_FLUSH+) 1)
121     (t
122       ;; (warn "lisp-ctrl(~A,~A,~A)" cmd larg parg)
123       0)))
124 
125 (cffi:defcallback lisp-create :int ((bio :pointer))
126   (setf (cffi:foreign-slot-value bio '(:struct bio) 'init) 1)
127   (setf (cffi:foreign-slot-value bio '(:struct bio) 'num) 0)
128   (setf (cffi:foreign-slot-value bio '(:struct bio) 'ptr) (cffi:null-pointer))
129   (setf (cffi:foreign-slot-value bio '(:struct bio) 'flags) 0)
130   1)
131 
132 (cffi:defcallback lisp-destroy :int ((bio :pointer))
133   (cond
134     ((cffi:null-pointer-p bio) 0)
135     (t
136       (setf (cffi:foreign-slot-value bio '(:struct bio) 'init) 0)
137       (setf (cffi:foreign-slot-value bio '(:struct bio) 'flags) 0)
138       1)))
139 
140 (setf *bio-lisp-method* nil)    ;force reinit if anything changed here