/[pg]/pg/sysdep.lisp
ViewVC logotype

Contents of /pg/sysdep.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (hide annotations)
Thu Apr 1 18:35:19 2004 UTC (10 years ago) by emarsden
Branch: MAIN
Changes since 1.4: +14 -2 lines
  - add md5 authentication (thanks to Brian Mastenbrook). Uses Pierre Mai's
    portable md5.lisp library, that has been added to the project (with extra
    EVAL-WHENness to please OpenMCL and ACL).

    Tested with CMUCL, SBCL, OpenMCL, CLISP, ACL 6.1. ABCL does not compile
    md5.lisp, probably for more EVAL-WHEN reasons. Only tested with PostgreSQL
    version 7.4.
1 emarsden 1.2 ;;; sysdep.lisp -- system-dependent parts of pg-dot-lisp
2     ;;;
3     ;;; Author: Eric Marsden <emarsden@laas.fr>
4 emarsden 1.5 ;;; Time-stamp: <2004-04-01 emarsden>
5 emarsden 1.2 ;;
6     ;;
7 emarsden 1.1
8 emarsden 1.2 (in-package :postgresql)
9 emarsden 1.1
10     (eval-when (:compile-toplevel :load-toplevel :execute)
11     #+allegro (require :socket)
12     #+lispworks (require "comm")
13     #+cormanlisp (require :sockets)
14 emarsden 1.5 #+sbcl (progn (require :asdf) (require :sb-bsd-sockets) (require :sb-md5))
15 emarsden 1.1 #+(and mcl (not openmcl)) (require "OPENTRANSPORT"))
16    
17    
18     #+(and cmu glibc2)
19     (eval-when (:compile-toplevel :load-toplevel)
20     (format t ";; Loading libcrypt~%")
21     ;; (ext:load-foreign "/lib/libcrypt.so.1")
22     (sys::load-object-file "/usr/lib/libcrypt.so"))
23    
24     #+(and cmu glibc2)
25     (defun crypt (key salt)
26     (declare (type string key salt))
27     (alien:alien-funcall
28     (alien:extern-alien "crypt"
29     (function c-call:c-string c-call:c-string c-call:c-string))
30     key salt))
31    
32     #-(and cmu glibc2)
33     (defun crypt (key salt)
34     (declare (ignore salt))
35     key)
36 emarsden 1.5
37    
38     (defun md5-digest (string &rest strings)
39     (declare (type simple-string string))
40     (let ((vec (md5:md5sum-sequence
41     (apply #'concatenate 'string string strings))))
42     (format nil "~(~{~2,'0X~}~)" (coerce vec 'list))))
43    
44     (defun md5-encode-password (user password salt)
45     (concatenate 'string "md5"
46     (md5-digest (md5-digest password user) salt)))
47    
48 emarsden 1.1
49    
50     ;; this is a little fiddly, because CLISP can be built without support
51     ;; for the Linux package
52     ;; #+CLISP
53     ;; (defun crypt (key salt)
54     ;; (linux::crypt key salt))
55    
56    
57     ;; bug in WRITE-SEQUENCE in CMUCL
58     #+(or cmu18c cmu18d)
59     (defun write-sequence (seq stream &key start end)
60     (declare (ignore start end))
61     (loop :for element :across seq
62     :do (write-byte element stream)))
63    
64    
65    
66     ;; work around bug in FASL fop dumping
67     #+cmu (setf c::top-level-lambda-max 0)
68    
69    
70     #+(and cmu ssl)
71     (defun socket-connect (port host)
72     (declare (type integer port))
73     (handler-case
74     (let ((fd (ext:connect-to-inet-socket host port)))
75     (ssl:make-ssl-client-stream fd))
76     (error (e)
77     (error 'connection-failure
78     :host host
79     :port port
80     :transport-error e))))
81    
82    
83     #+cmu
84     (defun socket-connect (port host)
85     (declare (type integer port))
86     (handler-case
87     (let ((fd (if host
88     (ext:connect-to-inet-socket host port)
89     (ext:connect-to-unix-socket
90     (format nil "/var/run/postgresql/.s.PGSQL.~D" port)))))
91     (sys:make-fd-stream fd :input t :output t
92     :element-type '(unsigned-byte 8)))
93     (error (e)
94     (error 'connection-failure
95     :host host
96     :port port
97     :transport-error e))))
98    
99     ;; this doesn't currently work, because WRITE-SEQUENCE is not
100     ;; implemented
101     #+(and cmu simple-streams broken)
102     (defun socket-connect (port host)
103     (declare (type integer port))
104     (handler-case
105     (make-instance 'stream:socket-simple-stream
106     :remote-host host
107     :remote-port port
108     :direction :io)
109     (error (e)
110     (error 'connection-failure
111     :host host
112     :port port
113     :transport-error e))))
114    
115     #+clisp
116     (defun socket-connect (port host)
117     (declare (type integer port))
118     (handler-case
119     (#+lisp=cl socket:socket-connect
120     #-lisp=cl lisp:socket-connect
121     port host :element-type '(unsigned-byte 8))
122     (error (e)
123     (declare (ignore e))
124     (error 'connection-failure :host host :port port))))
125    
126    
127 emarsden 1.4 #+(and db-sockets broken)
128 emarsden 1.1 (defun socket-connect (port host)
129     (declare (type integer port))
130     (handler-case
131     (let ((s (sockets:make-inet-socket :stream :tcp))
132     (num (car (sockets:host-ent-addresses
133     (sockets:get-host-by-name host)))))
134     (sockets:socket-connect s num port)
135     (sockets:socket-make-stream s :element-type '(unsigned-byte 8)
136     :input t :output t :buffering :none))
137     (error (e)
138     (error 'connection-failure
139     :host host
140     :port port
141     :transport-error e))))
142    
143     #+sbcl
144     (defun socket-connect (port host)
145     (declare (type integer port))
146     (handler-case
147     (sb-bsd-sockets:socket-make-stream
148     (if host
149     (let ((s (make-instance 'sb-bsd-sockets:inet-socket
150     :type :stream :protocol :tcp))
151     (num (car (sb-bsd-sockets:host-ent-addresses
152     (sb-bsd-sockets:get-host-by-name host)))))
153     (sb-bsd-sockets:socket-connect s num port)
154     s)
155     (let ((s (make-instance 'sb-bsd-sockets:local-socket :type :stream)))
156     (sb-bsd-sockets:socket-connect
157     s (format nil "/var/run/postgresql/.s.PGSQL.~D" port))
158     s))
159     :element-type '(unsigned-byte 8)
160     :input t
161     :output t
162     :buffering :none)
163     (error (e)
164     (error 'connection-failure :host host :port port :transport-error e))))
165    
166     #+allegro
167     (defun socket-connect (port host)
168     (declare (type integer port))
169     (handler-case
170     (socket:make-socket :remote-host host
171     :remote-port port
172     :format :binary)
173     (error (e)
174 emarsden 1.3 (error 'connection-failure
175 emarsden 1.1 :host host
176     :port port
177     :transport-error e))))
178    
179     ;; Lispworks 4.2 doesn't seem to implement WRITE-SEQUENCE on binary
180     ;; streams. Fixed in version 4.3.
181     #+lispworks
182     (defun socket-connect (port host)
183     (declare (type integer port))
184 emarsden 1.3 (handler-case
185     (comm:open-tcp-stream host port
186     :element-type '(unsigned-byte 8)
187     :direction :io)
188     (error (e)
189     (error 'connection-failure
190     :host host
191     :port port
192     :transport-error e))))
193 emarsden 1.1
194     ;; this doesn't work, since the Corman sockets module doesn't support
195     ;; binary I/O on socket streams.
196     #+cormanlisp
197     (defun socket-connect (port host)
198     (declare (type integer port))
199     (handler-case
200     (progn
201     (sockets:start-sockets)
202     (let ((sock (sockets:make-client-socket :host host :port port)))
203     (sockets:make-socket-stream sock)))
204     (error (e)
205 emarsden 1.3 (error 'connection-failure
206     :host host
207     :port port
208     :transport-error e))))
209 emarsden 1.1
210     #+openmcl
211     (defun socket-connect (port host)
212     (declare (type integer port))
213 emarsden 1.3 (handler-case
214     (if host
215     (make-socket :address-family :internet
216     :type :stream
217     :connect :active
218     :format :binary
219     :remote-host host
220     :remote-port port)
221     (make-socket :address-family :file
222     :type :stream
223     :connect :active
224     :format :binary
225     :remote-filename (format nil "/var/run/postgresql/.s.PGSQL.~D" port)))
226     (error (e)
227     (error 'connection-failure
228     :host host
229     :port port
230     :transport-error e))))
231 emarsden 1.1
232     ;; from John DeSoi
233     #+(and mcl (not openmcl))
234     (defun socket-connect (port host)
235     (declare (type integer port))
236     (ccl::open-tcp-stream host port :element-type '(unsigned-byte 8)))
237    
238     ;; There is a bug in MCL (4.3.1 tested) where read-sequence and
239     ;; write-sequence fail with binary tcp streams. These two methods
240     ;; provide a work-around.
241     #+(and mcl (not openmcl))
242     (defmethod ccl:stream-write-sequence ((s ccl::opentransport-binary-tcp-stream)
243     (sequence ccl::simple-unsigned-byte-vector)
244     &key (start 0) end)
245     (ccl::stream-write-vector s sequence start (or end (length sequence)))
246     s)
247    
248     #+(and mcl (not openmcl))
249     (defmethod ccl:stream-read-sequence ((s ccl::opentransport-binary-tcp-stream)
250     (sequence ccl::simple-unsigned-byte-vector)
251     &key (start 0) (end (length sequence)))
252     (ccl::io-buffer-read-bytes-to-vector (ccl::stream-io-buffer s)
253     sequence (- end start) start)
254     end)
255    
256    
257     ;; there seems to be a bug in ECL's binary socket streams; data is corrupted
258     #+ecl
259     (defun socket-connect (port host)
260     (declare (type integer port))
261 emarsden 1.3 (handler-case
262     (si:open-client-stream host port)
263     (error (e)
264     (error 'connection-failure
265     :host host
266     :port port
267     :transport-error e))))
268 emarsden 1.1
269    
270    
271     ;; as of version 2.6 GCL is way too broken to run this: DEFPACKAGE doesn't
272     ;; work, DEFINE-CONDITION not implemented, ...
273     #+gcl
274     (defun socket-connect (port host)
275     (declare (type integer port))
276     (si::socket port :host host))
277    
278    
279 emarsden 1.4
280     #+armedbear
281     (eval-when (:load-toplevel :execute :compile-toplevel)
282     (require 'format))
283    
284     ;; MAKE-SOCKET with :element-type as per 2004-03-09
285 emarsden 1.1 #+armedbear
286     (defun socket-connect (port host)
287     (declare (type integer port))
288 emarsden 1.3 (handler-case
289 emarsden 1.4 (ext:make-socket host port :element-type '(unsigned-byte 8))
290 emarsden 1.3 (error (e)
291     (error 'connection-failure
292     :host host
293     :port port
294     :transport-error e))))
295 emarsden 1.1
296    
297     ;; EOF

  ViewVC Help
Powered by ViewVC 1.1.5