Can anyone point me to a Common Lisp library (specifically for SBCL on Linux) for pulling pop3 email over SSL/TLS? Cl-pop seems fine, but it doesn't seem to support SSL and I'm not sure how to wrap it into CL+SSL (assuming it's possible). Does anyone have any suggestions short of rolling your own?
You can redefine the usocket-connect function to yield the stream type returned by the SSL library. Then you can define methods to send and receive data over this stream using regular strings (the SSL library only supports binary by default, but CL-POP assumes that strings can be sent). You'll need to depend on the FLEXI-STREAMS library to convert between text and binary. (ql:quickload :flexi-streams)
The following is code to make the change and define the needed methods. Since usocket-connect is replaced, I provide the :unencrypted keyword to create a regular socket.
The code could probably be made more efficient.
The string-to-octets and octets-to-string functions support an :external-format argument which allows them to encode/decode many character encoding schemes, including UTF-8, ISO-8859-*, and others. The full list of supported encodings is documented here. I didn't use :external-format in this answer, so it defaults to :latin-1.
The code is written against an old version of CL+SSL that seems to have been installed on my system by the Debian package manager. The current versions of make-ssl-client-stream and make-ssl-server-stream support several more keyword arguments than are supported by the version on my machine. It doesn't matter, however, because CL-POP will use none of these keyword arguments.
(defpackage :ssl-pop
(:use :common-lisp :cl+ssl :usocket :flexi-streams))
(in-package :ssl-pop)
(let ((old-connect (symbol-function 'socket-connect)))
(defun socket-connect (host port &key (protocol :stream)
external-format certificate key crypto-password
(clientp t) close-callback unencrypted
(unwrap-streams-p t) crypto-hostname
(element-type '(unsigned-byte 8)) timeout deadline
(nodelay t nodelay-specified) local-host
local-port)
(let* ((old-connect-args
`(,host ,port :protocol ,protocol
:element-type ,element-type
:timeout ,timeout :deadline ,deadline
,#(if nodelay-specified
`(:nodelay ,nodelay))
:local-host ,local-host
:local-port ,local-port))
(plain-socket (apply old-connect old-connect-args)))
(if unencrypted
plain-socket
(let ((socket-stream (socket-stream plain-socket)))
(assert (streamp socket-stream))
(if clientp
(make-ssl-client-stream socket-stream
:external-format external-format
:certificate certificate
:key key
:close-callback close-callback)
(make-ssl-server-stream socket-stream
:external-format external-format
:certificate certificate
:key key)))))))
(defmethod socket-stream ((object cl+ssl::ssl-stream))
object)
(defmethod socket-receive ((socket cl+ssl::ssl-stream) buffer length
&key (element-type '(unsigned-byte 8)))
(let ((buffer (or buffer (make-array length
:element-type element-type))))
(loop for ix from 0 below length
do
(restart-case
(setf (aref buffer ix) (read-byte socket))
(thats-ok () :report "Return the bytes that were successfully read"
(return-from socket-receive (subseq buffer 0 ix)))))
buffer))
(defmethod socket-send ((socket cl+ssl::ssl-stream) buffer length
&key host port)
(declare (ignore host port)) ;; They're for UDP
(loop for byte across buffer
do (write-byte byte socket)))
(defmethod sb-gray:stream-read-line ((socket cl+ssl::ssl-stream))
(let ((result (make-array 0 :adjustable t :fill-pointer t
:element-type '(unsigned-byte 8))))
(loop for next-byte = (read-byte socket)
until (and (>= (length result) 1)
(= next-byte 10)
(= (aref result (- (length result) 1)) 13))
do
(vector-push-extend next-byte result))
(octets-to-string
(concatenate 'vector
(subseq result 0 (- (length result) 1))))))
(defmethod trivial-gray-streams:stream-write-sequence
((stream cl+ssl::ssl-stream) (sequence string) start end
&key &allow-other-keys)
(trivial-gray-streams:stream-write-sequence stream
(string-to-octets sequence)
start end))
(defmethod sb-gray:stream-write-char ((stream cl+ssl::ssl-stream)
(char character))
(let ((string (make-string 1 :initial-element char)))
(write-sequence (string-to-octets string) stream)))
(defmethod socket-close ((socket cl+ssl::ssl-stream))
(close socket))
Related
Language: Racket (with SQL query code/pointer)
Libraries: db, racket/stream, racket/sequence
Goal: lazily process the value of sql queries using streams in Racket.
Question 1: how do you manipulate SQL query stream objects in Racket? (I can get the stream-first value of the stream but not the rest of the stream!)
#lang racket/base
(require db
racket/sequence
racket/stream)
(define db_sql_local
(mysql-connect
#:user "<my-username>"
#:database "<my-database>"
#:server "<my-server>"
#:port <my-port>
#:password "<my-password>"))
;; PROBLEM 1 HERE
(define test-stream
(sequence->stream
(in-query
chembl_sql_local
"SELECT * FROM <table-name>"
#:fetch +inf.0)))
(stream-first test-stream)
;; stream-first of test-stream returns the first-row of the table as a '(#vector).
Any advice or comments would be greatly appreciated - Thank you!
First, the sequence returned by in-query does not contain vectors; each "element" of the sequence contains multiple values, one per column returned. See the paragraph in the Sequence docs starting "Individual elements of a sequence..." about multiple-valued elements.
Second, using #:fetch +inf.0 (the default behavior) means that all rows are fetched before the sequence is returned. So there's nothing lazy about the code above; you could use query-rows instead and get a list, which would be easier to work with (and query-rows does represent each row as a vector).
Finally, use stream-rest to get the rest of a stream. For example:
(require db racket/stream racket/sequence)
(define c (sqlite3-connect #:database 'memory))
(define qseq (in-query c "SELECT 1, 2 UNION SELECT 3, 4" #:fetch 1))
qseq
;; => #<sequence>
(define qstream (sequence->stream qseq))
qstream
;; => #<stream>
(stream-first qstream)
;; => 1 2
(stream-rest qstream)
;; => #<stream>
(stream-first (stream-rest qstream))
;; => 3 4
thanks for your quick reply. The #:fetch 1 arg was definitely what I was looking for to make it lazy. I've attached updated code that should lazily stream sql queries to export tsv files.
(define sql_server
(mysql-connect
#:user <username>
#:database <db-name>
#:server <server>
#:port <port-num>
#:password <password>))
(define query-->stream
(lambda (db-conn query)
(sequence->stream
(in-query
db-conn
query
#:fetch 1))))
(define print-table-row-to-tsv
(lambda (ls port)
(cond
((null? ls)
(fprintf port "~c" #\newline)
(void))
((sql-null? (car ls))
(fprintf port "~a~c" "NULL" #\tab)
(print-table-row-to-tsv (cdr ls) port))
((null? (cdr ls))
(fprintf port "~a" (car ls))
(print-table-row-to-tsv (cdr ls) port))
(else
(fprintf port "~a~c" (car ls) #\tab)
(print-table-row-to-tsv (cdr ls) port)))))
(define get-table-col-names
(lambda (db-conn tbl-name)
(map (lambda (x) (vector-ref x 0))
(query-rows db-conn (string-append "DESCRIBE " tbl-name)))))
(define export-query-result-to-tsv
(lambda (db-conn tbl-name query)
(let* ((tbl-col-names (get-table-col-names db-conn tbl-name))
(output-file (open-output-file (format "~achembl_~a_table.tsv" (find-system-path 'home-dir) tbl-name) #:exists 'replace))
(stream (query-->stream db-conn query)))
(begin
(print-table-row-to-tsv tbl-col-names output-file)
(process-stream-to-tsv stream output-file)
(close-output-port output-file)))))
(define process-stream-to-tsv
(lambda (stream port)
(cond
((stream-empty? stream)
(void))
(else
(begin
(print-table-row-to-tsv (call-with-values (lambda () (stream-first stream)) list) port)
(process-stream-to-tsv (stream-rest stream) port))))))
(export-query-result-to-tsv sql_server "<table-name>" "SELECT * FROM <table-name>;")
This question already has an answer here:
How to handle accents in Common Lisp (SBCL)?
(1 answer)
Closed 6 years ago.
Trying
loading contents of file containing one line with word: λέξη
(with-open-file (s PATH-TO-FILE :direction :input)
(let ((a (read-line s)))
(print a)))
outputs
""
T
Trying:
(with-open-file (s PATH-TO-FILE :direction :input)
(let ((buffer ""))
(do ((character (read-char s nil) (read-char s nil)))
((null character))
(setf buffer (concatenate 'string buffer (format nil "~a" character))))
(format t "~a" buffer)))
outputs
funny characters (nothing like the original contents)
T
What I would like to do is to load all lines of file containing such non-standard characters.
Then I want to be able to output these words to console or via LTK widgets (text on button for example).
You need to pass :external-format X to with-open-file, where
X is the actual encoding used in the file (:utf-8 or :ISO-8859-7 or whatever).
(with-open-file (stream PATH-TO-FILE :external-format :utf-8)
(let ((line (read-line stream)))
(loop :for char :across line :do
(print (list (char-name char) (char-code char))))
line))
Since it prints
("ZERO_WIDTH_NO-BREAK_SPACE" 65279)
("GREEK_SMALL_LETTER_LAMDA" 955)
("GREEK_SMALL_LETTER_EPSILON_WITH_TONOS" 941)
("GREEK_SMALL_LETTER_XI" 958)
("GREEK_SMALL_LETTER_ETA" 951)
you can see that you are, indeed, reading the file correctly.
Your problem now if how to print those non-ASCII characters to the screen, and that is an entirely different question.
Context:
I have a text file called fr.txt with 3 columns of text in it:
65 A #\A
97 a #\a
192 À #\latin_capital_letter_a_with_grave
224 à #\latin_small_letter_a_with_grave
etc...
I want to create a function to read the first (and eventually the third one too) column and write it into another text file called alphabet_code.txt.
So far I have this function:
(defun alphabets()
(setq source (open "fr.txt" :direction :input :if-does-not-exist :error))
(setq code (open "alphabet_code.txt" :direction :output :if-does-not-exist :create :if-exists :supersede))
(loop
(setq ligne (read-line source nil nil))
(cond
((equal ligne nil) (return))
(t (print (read-from-string ligne) code))
)
)
(close code)
(close source)
)
My problems:
I don't really understand how the parameters of read-line function. I have read this doc, but it's still very obscure to me. If someone would have very simple examples, that would help.
With the current code, I get this error: *** - read: input stream #<input string-input-stream> has reached its end even if I change the nil nil in (read-line source nil nil) to other values.
Thanks for your time!
Your questions
read-line optional arguments
read-line accepts 3 optional arguments:
eof-error-p: what to do on EOF (default: error)
eof-value: what to return instead of the error when you see EOF
recursive-p: are you calling it from your print-object method (forget about this for now)
E.g., when the stream is at EOF,
(read-line stream) will signal the end-of-file error
(read-line stream nil) will return nil
(read-line stream nil 42) will return 42.
Note that (read-line stream nil) is the same as (read-line stream nil nil) but people usually still pass the second optional argument explicitly.
eof-value of nil is fine for read-line because nil is not a string and read-line only returns strings.
Note also that in case of read the second optional argument is, traditionally, the stream itself: (read stream nil stream). It's quite convenient.
Error
You are getting the error from read-from-string, not read-line, because, apparently, you have an empty line in your file.
I know that because the error mentions string-input-stream, not file-stream.
Your code
Your code is correct functionally, but very wrong stylistically.
You should use with-open-file whenever possible.
You should not use print in code, it's a weird legacy function mostly for interactive use.
You can't create local variables with setq - use let or other equivalent forms (in this case, you never need let! :-)
Here is how I would re-write your function:
(defun alphabets (input-file output-file)
(with-open-stream (source input-file)
(with-open-stream (code output-file :direction :output :if-exists :supersede)
(loop for line = (read-line source nil nil)
as num = (parse-integer line :junk-allowed t)
while line do
(when num
(write num :stream code)
(write-char #\Newline code))))))
(alphabets "fr.txt" "alphabet_code.txt")
See the docs:
loop: for/as, while, do
write, write-char
parse-integer
Alternatively, instead of (when num ...) I could have use the corresponding loop conditional.
Also, instead of write+write-char I could have written (format code "~D~%" num).
Note that I do not pass those of your with-open-stream arguments that are identical to the defaults.
The defaults are set in stone, and the less code you have to write and your user has to read, the less is the chance of an error.
I need to make the function defmacro for my meta-circular interpreter that can read this syntax:
pseudoscheme> (defmacro (minus x y) (list ‘- y x))
MINUS
pseudoscheme> (expand-macro '(minus 3 2))
(- 3 2)
When I use this:
(defmacro my-defmacro ((name &rest args) &body body)
(let ((form (gensym))(env (gensym)))
(progn
`(setf (macro-function ',name)
(lambda (,form ,env))
(destructuring-bind ,args (rest, form) ,#body))
name
)
)
)
and then:
(my-defmacro (min a b)(list '- a b))
I get this error:
Error: The variable MIN is unbound.
I can't understand why.
-----EDITED-----
If I use this:
(defmacro my-defmacro ((name &rest args) &body body)
(let ((form (gensym))(env (gensym)))
`(progn (setf (macro-function ',name)
(lambda (,form ,env))
(destructuring-bind ,args (rest, form) ,#body))
',name)
)
)
and then:
(my-defmacro (min a b)(list '- a b))
I get this error:
Error: Odd number of args to SETF: ((MACRO-FUNCTION (QUOTE PLUS)) (LAMBDA (#:G786 #:G787)) (DESTRUCTURING-BIND (A B) (REST #:G786) (LIST # A B)))
Your my-defmacro works for you host CL system, but I get the feeling you want macro capabilities in your interpreter and this won't do it. (except if ythe interpreter environment is the global host implementations environment, but that would make a lot of challenges)
I don't know how you do compound procedures in your evaluator but when my evaluator gets a (lambda (x) (+ x x)) it is turned into (compound-procedure <env> (x) (+ x x)). My macros turn into almost the same except the first element is compound-syntax.
Every evaluated operator has a tag which tells it what it is (one of primitive-syntax, primitive-procedure, compound-syntax, compound-procedure) and I only need a general way of dealing with those 4.
The real difference between a compound procedure and compound syntax is that the arguments gets evaluated for a procedure and in a compound syntax the result gets evaluated.
So. Have you implemented so that ((lambda (x) (+ x x)) 5) works? Well, then you'll almost implemented macros as well. This is of course not true for a compiler, since this approach would expand the code every time it's run instead of expanding once when the closure gets created. (Optimizations is no way to go on the first version anyway)
For your 'edited code' you have a misplaced paren:
(defmacro my-defmacro ((name &rest args) &body body)
(let ((form (gensym))(env (gensym)))
`(progn (setf (macro-function ',name)
(lambda (,form ,env)) ;; <== HERE
(destructuring-bind ,args (rest, form) ,#body))
',name)
)
)
which leads to setf having three subforms. Rewrite it like this (while using standard Lisp formatting):
(defmacro my-defmacro ((name &rest args) &body body)
(let ((form (gensym))
(env (gensym)))
`(progn (setf (macro-function ',name)
(lambda (,form ,env)
(destructuring-bind ,args (rest, form)
,#body)))
',name)))
I want to count the number of rows in a flat file, and so I wrote the code:
(defun ff-rows (dir file)
(with-open-file (str (make-pathname :name file
:directory dir)
:direction :input)
(let ((rownum 0))
(do ((line (read-line str file nil 'eof)
(read-line str file nil 'eof)))
((eql line 'eof) rownum)
(incf rownum )))))
However I get the error:
*** - READ: input stream
#<INPUT BUFFERED FILE-STREAM CHARACTER #P"/home/lambda/Documents/flatfile"
#4>
ends within an object
May I ask what the problem is here? I tried counting the rows; this operation is fine.
Note: Here is contents of the flat file that I used to test the function:
2 3 4 6 2
1 2 3 1 2
2 3 4 1 6
A bit shorter.
(defun ff-rows (dir file)
(with-open-file (stream (make-pathname :name file
:directory dir)
:direction :input)
(loop for line = (read-line stream nil nil)
while line count line)))
Note that you need to get the arguments for READ-LINE right. First is the stream. A file is not part of the parameter list.
Also generally is not a good idea to mix pathname handling into general Lisp functions.
(defun ff-rows (pathname)
(with-open-file (stream pathname :direction :input)
(loop for line = (read-line stream nil nil)
while line count line)))
Do the pathname handling in another function or some other code. Passing pathname components to functions is usually a wrong design. Pass complete pathnames.
Using a LispWorks file selector:
CL-USER 2 > (ff-rows (capi:prompt-for-file "some file"))
27955
Even better is when all the basic I/O functions work on streams, and not pathnames. Thus you you could count lines in a network stream, a serial line or some other stream.
The problem, as far as I can tell, is the "file" in your (read-line ... ) call.
Based on the hyperspec, the signature of read-line is:
read-line &optional input-stream eof-error-p eof-value recursive-p
=> line, missing-newline-p
...which means that "file" is interpreted as eof-error-p, nil as eof-value and 'eof as recursive-p. Needless to say, problems ensue. If you remove "file" from the read-line call (e.g. (read-line str nil :eof)), the code runs fine without further modifications on my machine (AllegroCL & LispWorks.)
(defun ff-rows (dir file)
(with-open-file
(str (make-pathname :name file :directory dir)
:direction :input)
(let ((result 0))
(handler-case
(loop (progn (incf result) (read-line str)))
(end-of-file () (1- result))
(error () result)))))
Now, of course if you were more pedantic then I am, you could've specified what kind of error you want to handle exactly, but for the simple example this will do.
EDIT: I think #Moritz answered the question better, still this may be an example of how to use the error thrown by read-line to your advantage instead of trying to avoid it.