Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

Lispworks feature fix #128

Open
wants to merge 3 commits into
base: master
Choose a base branch
from
Open

Lispworks feature fix #128

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
7d47963
Simplified feature tests for Lispworks.
Nov 7, 2022
91ad4a8
Changes for Lispworks 7.
Nov 7, 2022
dc5aa3d
Improvement suggested by svenemtell: feature :lw-use-comm is not avai…
Nov 16, 2022
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
28 changes: 23 additions & 5 deletions drakma.asd
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -29,21 +29,35 @@

(in-package :cl-user)

#+:lispworks
(unless (find-symbol "STREAM-WRITE-TIMEOUT" :stream)
(pushnew :lw-does-not-have-write-timeout *features*))

(defpackage :drakma-asd
(:use :cl :asdf))

(in-package :drakma-asd)

;;; When working on drakma under Lispworks, run (setup-lw-features)
;;; to ensure that the Lispworks-related features are added.
#+:lispworks
(defun setup-lw-features ()
(unless (find-symbol "STREAM-WRITE-TIMEOUT" :stream)
(pushnew :lw-does-not-have-write-timeout *features*))
#+(or :lispworks4 :lispworks5 :lispworks6)
(pushnew :lw-simple-char *features*)
#-(or :lispworks4 :lispworks5 :lispworks6)
(pushnew :lw-use-comm *features*))

(defsystem :drakma
:description "Full-featured http/https client based on usocket"
:author "Dr. Edi Weitz"
:license "BSD"
:serial t
:version "2.0.9"
#+:lispworks
:around-compile
#+:lispworks
(lambda (next)
(let ((*features* (copy-seq *features*)))
(setup-lw-features)
(funcall next)))
:components ((:file "packages")
(:file "specials")
(:file "conditions")
Expand All @@ -59,7 +73,11 @@
:cl-ppcre
#-:drakma-no-chipz :chipz
#-:lispworks :usocket
#-(or :lispworks7.1 (and :allegro (not :allegro-cl-express)) :mocl-ssl :drakma-no-ssl) :cl+ssl)
#-(or (and lispworks (not (or lispworks4 lispworks5 lispworks6)))
(and :allegro (not :allegro-cl-express))
:mocl-ssl
:drakma-no-ssl)
:cl+ssl)
:perform (test-op (o s)
(asdf:load-system :drakma-test)
(asdf:perform 'asdf:test-op :drakma-test)))
72 changes: 56 additions & 16 deletions request.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -160,7 +160,8 @@ headers of the chunked stream \(if any) as a second value."
(header-value :content-length headers)))
(parse-integer value)))
(element-type (if textp
#+:lispworks7.1 'lw:simple-char #-:lispworks7.1 'character
#+:lw-simple-char 'lw:simple-char
#-:lw-simple-char 'character
'octet)))
(values (cond ((eql content-length 0) nil)
(content-length
Expand Down Expand Up @@ -239,8 +240,8 @@ headers of the chunked stream \(if any) as a second value."
decode-content ; default to nil for backwards compatibility
#+(or abcl clisp lispworks mcl openmcl sbcl)
(connection-timeout 20)
#+:lispworks7.1 (read-timeout 20)
#+(and :lispworks7.1 (not :lw-does-not-have-write-timeout))
#+:lispworks (read-timeout 20)
#+(and :lispworks (not :lw-does-not-have-write-timeout))
(write-timeout 20 write-timeout-provided-p)
#+:openmcl
deadline
Expand Down Expand Up @@ -489,8 +490,9 @@ decoded according to any encodings specified in the Content-Encoding
header. The actual decoding is done by the DECODE-STREAM generic function,
and you can implement new methods to support additional encodings.
Any encodings in Transfer-Encoding, such as chunking, are always performed."
#+lispworks7.1
(declare (ignore certificate key certificate-password verify max-depth ca-file ca-directory))
#+:lw-use-comm
(declare (ignore certificate key certificate-password max-depth ca-file ca-directory))
(declare (ignorable write-timeout-provided-p))
(unless (member protocol '(:http/1.0 :http/1.1) :test #'eq)
(parameter-error "Don't know how to handle protocol ~S." protocol))
(setq uri (cond ((puri:uri-p uri) (puri:copy-uri uri))
Expand Down Expand Up @@ -565,7 +567,7 @@ Any encodings in Transfer-Encoding, such as chunking, are always performed."
(drakma-warn "Disabling WRITE-TIMEOUT because it doesn't mix well with SSL."))
(setq write-timeout nil))
(setq http-stream (or stream
#+:lispworks7.1
#+:lw-use-comm
(comm:open-tcp-stream host port
:element-type 'octet
:timeout connection-timeout
Expand All @@ -575,7 +577,7 @@ Any encodings in Transfer-Encoding, such as chunking, are always performed."
#-:lw-does-not-have-write-timeout
write-timeout
:errorp t)
#-:lispworks7.1
#-:lw-use-comm
(usocket:socket-stream
(usocket:socket-connect host port
:element-type 'octet
Expand Down Expand Up @@ -607,14 +609,32 @@ Any encodings in Transfer-Encoding, such as chunking, are always performed."
(when (and use-ssl
;; don't attach SSL to existing streams
(not stream))
#+:lispworks7.1
#+:lw-use-comm
(comm:attach-ssl http-stream
:ssl-side :client
#-(or lispworks4 lispworks5 lispworks6)
:ssl-ctx
#-:lispworks7
(comm:create-ssl-client-context
:verify-callback (ecase verify
((nil) nil)
((:optional) :try)
((:required) t)))
#+:lispworks7
(progn
(let ((ctx
(comm:make-ssl-ctx :ssl-side :client)))
(when verify
(comm:set-verification-mode
ctx :client
(ecase verify
;;; not quite correct: we should validate certificate
;;; if one is provided
((:optional) nil)
((:required) :always))))
ctx))
:tlsext-host-name
#-(or lispworks4 lispworks5 lispworks6)
(puri:uri-host uri))
#-:lispworks7.1
#-:lw-use-comm
(setq http-stream (make-ssl-stream http-stream
:hostname (puri:uri-host uri)
:certificate certificate
Expand All @@ -626,7 +646,8 @@ Any encodings in Transfer-Encoding, such as chunking, are always performed."
:ca-directory ca-directory)))
(cond (stream
(setf (flexi-stream-element-type http-stream)
#+:lispworks6 'lw:simple-char #-:lispworks6 'character
#+:lw-simple-char 'lw:simple-char
#-:lw-simple-char 'character
(flexi-stream-external-format http-stream) +latin-1+))
(t
(setq http-stream (wrap-stream http-stream))))
Expand All @@ -648,14 +669,32 @@ Any encodings in Transfer-Encoding, such as chunking, are always performed."
;; got a connection; we have to read a blank line,
;; turn on SSL, and then we can transmit
(read-line* http-stream)
#+:lispworks7.1
#+:lw-use-comm
(comm:attach-ssl raw-http-stream
:ssl-side :client
#-(or lispworks4 lispworks5 lispworks6)
:ssl-ctx
#-:lispworks7
(comm:create-ssl-client-context
:verify-callback (ecase verify
((nil) nil)
((:optional) :try)
((:required) t)))
#+:lispworks7
(progn
(let ((ctx
(comm:make-ssl-ctx :ssl-side :client)))
(when verify
(comm:set-verification-mode
ctx :client
(ecase verify
;;; not quite correct: we should validate certificate
;;; if one is provided
((:optional) nil)
((:required) :always))))
ctx))
:tlsext-host-name
#-(or lispworks4 lispworks5 lispworks6)
(puri:uri-host uri))
#-:lispworks7.1
#-:lw-use-comm
(setq http-stream (wrap-stream
(make-ssl-stream raw-http-stream
:hostname (puri:uri-host uri)
Expand Down Expand Up @@ -900,3 +939,4 @@ Any encodings in Transfer-Encoding, such as chunking, are always performed."
(not want-stream)))
(not (eq content :continuation)))
(ignore-errors (close http-stream)))))))

4 changes: 2 additions & 2 deletions util.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -29,7 +29,7 @@

(in-package :drakma)

#+:lispworks
#+:lw-use-comm
(require "comm")

#+:lispworks
Expand Down Expand Up @@ -295,7 +295,7 @@ which are not meant as separators."
(setq cookie-start (1+ end-pos))
(go next-cookie))))))

#-:lispworks7.1
#-:lw-use-comm
(defun make-ssl-stream (http-stream &key certificate key certificate-password verify (max-depth 10) ca-file ca-directory
hostname)
"Attaches SSL to the stream HTTP-STREAM and returns the SSL stream
Expand Down