source: project/release/4/dict/trunk/dict.scm @ 14354

Last change on this file since 14354 was 14354, checked in by certainty, 11 years ago

removed superflous syntax. was a duplicate

File size: 19.3 KB
Line 
1;;; dict.scm ---
2;;
3;; Filename: dict.scm
4;; Description:
5;; Author: David Krentzlin <david@lisp-unleashed.de>
6;; Maintainer:
7;; Created: Di Apr 14 21:34:48 2009 (CEST)
8;; Version: $Id$
9;; Version:
10;; Last-Updated: Mi Apr 22 20:58:18 2009 (CEST)
11;;           By: David Krentzlin <david@lisp-unleashed.de>
12;;     Update #: 439
13;; URL:
14;; Keywords:
15;; Compatibility:
16;;
17;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
18;;
19;;; Commentary:
20;;
21;;
22;;
23;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
24;;
25;;; Change log:
26;;
27;;
28;; RCS $Log$
29;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
30;;
31;; Copyright (c) 2009 David Krentzlin <david@lisp-unleashed.de>
32;;
33;;   Permission is hereby granted, free of charge, to any person
34;;   obtaining a copy of this software and associated documentation
35;;   files (the "Software"), to deal in the Software without
36;;   restriction, including without limitation the rights to use,
37;;   copy, modify, merge, publish, distribute, sublicense, and/or sell
38;;   copies of the Software, and to permit persons to whom the
39;;   Software is furnished to do so, subject to the following
40;;   conditions:
41;;
42;;   The above copyright notice and this permission notice shall be
43;;   included in all copies or substantial portions of the Software.
44;;
45;;   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
46;;   EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
47;;   OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
48;;   NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
49;;   HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
50;;   WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
51;;   FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
52;;   OTHER DEALINGS IN THE SOFTWARE.
53;;
54;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
55;;
56;;; Code:
57
58
59(provide 'dict)
60(module dict
61  (status-response? response-status-code response-status-message response-status-code->string
62   response-status-error? status:n-databases-present? status:n-strategies-present?
63    status:database-information-follows? status:help-text-follows? status:server-information-follows?
64    status:challenge-follows? status:n-definitions-retrieved? status:word-database-name?
65    status:n-matches-retrieved? status:statistic? status:banner? status:closing-connection?
66    status:authentication-successful? status:ok? status:send-response? status:server-temporarily-unavailable?
67    status:shutdown-at-op-request? status:syntax-error-command? status:syntax-error-parameter?
68    status:command-not-implemented? status:parameter-not-implemented? status:access-denied?
69    status:access-denied-show-info? status:access-denied-unknown-mech? status:invalid-database?
70    status:invalid-strategy? status:no-match? status:no-database-present? status:no-strategies-present?
71    make-connection connect disconnect connection-msg-id connection-server-capabilities 
72    *current-log-port* !match !define !databases !strategies !server-information !database-information
73    !help !status !quit !announce-client)
74 
75  (import scheme chicken)
76  (require-library tcp defstruct regex srfi-13 srfi-14)
77  (import tcp defstruct 
78          (only srfi-14 char-set:digit)
79          (only srfi-13 string-join string-index string-trim-right string-trim-both string-trim string-skip string-take string-drop)
80          (only regex string-split-fields)
81          (only extras fprintf read-line)
82          (only data-structures alist-ref alist-update!))
83         
84
85  ;;add support for parsing mime-headers
86  ;;when option mime is set
87
88  (define (make-exn-condition loc msg . args)
89    (apply make-property-condition
90           'exn
91           (append (if loc (list 'location loc)  '())
92                   (if msg (list 'message msg) '())
93                   (if (and args (not (null? args))) (list 'arguments args) '()))))
94
95  (define (complain msg . args)
96    (signal (apply make-exn-condition #f msg args)))
97
98  ;;there are two kinds of answer we can expect from the
99  ;;dict-server.
100  ;;1) a status response which consists of a numeric status-code
101  ;;   optionally followed by textual information
102  ;;   The status-code may of may not have leading zeros
103  ;;2) data which has different formats depending on the request
104
105  ;;so a status response may be naturally represented using a pair.
106  (define (make-status-response code msg)
107    (unless (and (integer? code) (positive? code))
108      (complain"First argument to make-status-response must be a positive integer"))
109    (unless (string? msg)
110      (complain "Second argument to make-status-response must be a non-empty string"))
111    (cons code msg))
112 
113  (define (status-response? arg)
114    (and (pair? arg) (number? (car arg)) (string? (cdr arg))))
115
116  ;;accessors for convenience
117  (define response-status-code car)
118  (define response-status-message cdr)
119
120
121  ;;map status-codes to textual representation
122  (define +status-texts+ (list))
123  (define (add-status-text status)
124    (set! +status-texts+ (cons status +status-texts+)))
125
126  (define (response-status-code->string  code)
127    (let ((entry (alist-ref code +status-texts+)))
128      (if entry entry "")))
129
130  (define (response-status-error? resp)
131    (and (status-response? resp) (>= (response-status-code resp) 400)))
132
133
134  ;;add the status to the mapping
135  ;;create a predicate to test if a status-object is of a given type
136  ;;define a constant to that status
137  (define-syntax define-status
138    (lambda (exp rename compare)
139      (let* ((status-name (cadr exp))
140             (code (caddr exp))
141             (string (cadddr exp))
142             (predicate (string->symbol (string-append (symbol->string status-name) "?")))
143             (%begin (rename 'begin))
144             (%define (rename 'define))
145             (%and (rename 'and))
146             (%= (rename '=))
147             (%cons (rename 'cons))
148             (%status-resp? (rename 'status-response?))
149             (%status-code (rename 'response-status-code))
150             (%add-status-text (rename 'add-status-text)))
151        `(,%begin
152          (,%define ,status-name (,%cons ,code ,string))
153          (,%define (,predicate arg)
154                    (,%and (,%status-resp? arg) (,%= (,%status-code arg) ,code)))
155          (,%add-status-text ,status-name)))))
156 
157  (define-syntax define-cmd
158    (lambda (exp rename compare)
159      (let* ((cmd (cadr exp))
160             (%define (rename 'define))
161             (cmd-symbol (string->symbol (conc "+cmd:" (string-translate* (string-downcase cmd) '((" " . "-"))) "+"))))
162        `(,%define ,cmd-symbol ,(string-upcase cmd)))))
163
164  ;;1yz repsonse-codes
165  (define-status status:n-databases-present 110 "n databases present - text follows")
166  (define-status status:n-strategies-present 111 "n strategies available - text follows")
167  (define-status status:database-information-follows 112 "database information follows")
168  (define-status status:help-text-follows 113 "help text follows")
169  (define-status status:server-information-follows 114 "server information follows")
170  (define-status status:challenge-follows 130 "challenge follows")
171  (define-status status:n-definitions-retrieved 150 "n definitions retrieved - definitions follow")
172  (define-status status:word-database-name 151 "word database name - text follows")
173  (define-status status:n-matches-retrieved 152 "n matches found - text follows")
174
175  ;;2yz
176  (define-status status:statistic 210 "statistic")
177  (define-status status:banner 220 "banner")
178  (define-status status:closing-connection 221 "Closing Connection")
179  (define-status status:authentication-successful 230 "Authentication successful")
180  (define-status status:ok 250 "Ok")
181
182  ;;3yz
183  (define-status status:send-response 330 "send response")
184
185  ;;4yz
186  (define-status status:server-temporarily-unavailable 420 "Server temporarily unavailable")
187  (define-status status:shutdown-at-op-request 421 "Server shutting down at operator request")
188
189  ;;5yz
190  (define-status status:syntax-error-command 500 "Syntax error, command not recognized")
191  (define-status status:syntax-error-parameter 501 "Syntax error, illegal parameters")
192  (define-status status:command-not-implemented 502 "Command not implemented")
193  (define-status status:parameter-not-implemented 503 "Command parameter not implemented")
194  (define-status status:access-denied 530 "Access denied")
195  (define-status status:access-denied-show-info 531 "Access denied, use \"SHOW INFO\" for server information")
196  (define-status status:access-denied-unknown-mech 532 "Access denied, unknown mechanism")
197  (define-status status:invalid-database 550 "Invalid database, use \"SHOW DB\" for list of databases")
198  (define-status status:invalid-strategy 551 "Invalid strategy, use \"SHOW STRAT\" for a list of strategies")
199  (define-status status:no-match 552 "No match")
200  (define-status status:no-database-present 554 "No databases present")
201  (define-status status:no-strategies-present 555 "No strategies available")
202
203
204  (define *default-port* (make-parameter 2628))
205  (define +crlf+ "\r\n")
206
207 
208  (define-cmd "quit")
209  (define-cmd "client")
210  (define-cmd "define")
211  (define-cmd "match")
212  (define-cmd "show strat")
213  (define-cmd "show db")
214  (define-cmd "show info")
215  (define-cmd "show server")
216  (define-cmd "status")
217  (define-cmd "help")
218  (define-cmd "auth")
219  (define-cmd "option mime")
220
221  ;;banner-object
222  (define (make-banner text msg-id cap)
223    (unless (list? cap)
224      (complain "capabilities must be a string"))
225    (unless (and (string? text) (string? msg-id))
226      (complain "text and msg-id must be strings"))
227    (list text msg-id cap))
228
229  (define banner-msg-id cadr)
230  (define banner-text car)
231  (define banner-capabilities caddr)
232
233
234  ;;logging support
235  ;;every command and response will be logged
236  ;;to *current-log-port* if logging is enabled
237  (define *current-log-port* (make-parameter #f))
238
239
240  (define (dict-log  fmt . args)
241    (if (*current-log-port*)
242        (apply fprintf (*current-log-port*) fmt args)
243        #f))
244
245
246  ;;input routines and parsing
247
248  ;;readline with logging
249  ;;and optionally erroring when eof is received
250  (define (dict-read-line port #!optional (eof-is-error? #f))
251    (let ((line (read-line port)))
252      (when (and (eof-object? line) eof-is-error?)
253        (complain "unexpected eof received"))
254      (dict-log "<<: ~A~%" line)
255      line))
256
257
258  ;;parse a status response
259  ;;the rfc states that a legal status response
260  ;;is an integer representing the status-code (optionally with leading zeros)
261  ;;which is optionally followed by textual information
262  (define (parse-status-response input)
263    (let ((eoc (string-skip input char-set:digit)))
264      (cond
265       ((not eoc)   (make-status-response (string->number (string-trim-both (string-trim input #\0) #\space)) ""))
266       ((zero? eoc) (complain "Malformed status response " input))
267       (else        (make-status-response (string->number (string-trim (string-take input eoc) #\0)) (string-drop input (+ 1 eoc)))))))
268
269
270  (define (read-status-response port)
271    (parse-status-response (string-trim (dict-read-line port) #\space)))
272
273  ;;parse the banner status-response
274  ;;the textual information of the banner-status
275  ;;provides addtional information about the server
276  ;;we're interested in the message-id and the list of capabilities
277  (define (parse-banner input)
278    (let ((parts (reverse (string-split-fields "\\s+" input #:infix))))
279      (when (< (length parts) 2)
280        (complain "Malformed banner received"))
281      (let ((msg-id (car parts))
282            (cap (cadr parts)))
283        (if (and (positive? (string-length cap)) (char=? (string-ref cap 0) #\<))
284            (make-banner  (string-join (reverse (cddr parts)) " ")
285                          msg-id
286                          (string-split-fields "\\." (string-trim-right (string-trim cap #\<) #\>) #:infix))
287            (make-banner (string-join (reverse (cdr parts)) " ")
288                         msg-id
289                         '())))))
290
291  ;;input: the textual information of status 151
292  (define (parse-status-151 input)
293    (let ((ws (string-index input #\space)))
294      (unless ws (complain "Malformed status 151 response. Expected `word`" input))
295      (let ((word (string-trim-both (string-take input ws) #\"))
296            (ws2 (string-index input #\space (+ ws 1))))
297        (unless ws (complain "Malformed status 151 response. Expected `databasename`"  input))
298        (let ((db (string-trim-both (string-take (string-drop input (+ ws 1)) (- ws2 (+ 1 ws))) #\"))
299              (descr (string-trim-both (string-trim-both (string-drop input (+ 1 ws2)) #\space) #\")))
300          (list word db descr)))))
301
302  ;;fold input until we reach .\r\n 250 ok\r\n
303  (define (fold-input port knil kons)
304    (let loop ((expect-status? #f) (knil knil))
305      (if expect-status?
306          (let ((status (read-status-response port)))
307            (if (status:ok? status) knil (complain "Unexpected status response. Expected 250 ok" status)))
308          (let ((line (dict-read-line port #t)))
309            (if (string=? (string-trim-both line #\space) ".")
310                (loop #t knil)
311                (loop #f (kons knil line)))))))
312
313  ;;simply consume all text
314  (define (read-text port)
315    (fold-input port "" (cut string-append <> <> "\n")))
316
317
318  ;;consume all input building pairs out of each line
319  ;;used for example for strategy-lists
320  (define (line->pair line)
321    (let ((ws (string-index line #\space)))
322      (list (string-trim-both (string-take line ws) #\space) (string-trim-both (string-trim-both (string-drop line (+ ws 1)) #\space) #\"))))
323
324  (define (read-pairs port)
325    (reverse (fold-input port '() (lambda (lines line) (cons (line->pair line) lines)))))
326
327
328  (define (read-matches port)
329    (fold-input port '() (lambda (matches line)
330                           (let* ((match (line->pair line)))
331                             (alist-update! (car match)
332                                            (cons (cadr match) (alist-ref (car match) matches string-ci=? '()))
333                                            matches string-ci=?)))))
334
335  (define (read-definitions port)
336    (let loop ((expect-status? #t) (wdn '()) (text "") (defs '()))
337      (if expect-status?
338          (let ((status (read-status-response port)))
339            (cond
340             ((status:ok? status) (reverse defs))
341             ((status:word-database-name? status)
342              (loop #f (parse-status-151 (response-status-message status)) text defs))
343             (else (complain "unexpected status response" status))))
344          (let ((line (dict-read-line port #t)))
345            (if (string=? (string-trim-both line #\space) ".")
346                (loop #t '() "" (cons (append wdn (list text)) defs))
347                (loop #f wdn (string-append text line "\n") defs))))))
348 
349  ;;the connection-object
350  (defstruct connection input-port output-port connected msg-id text server-capabilities)
351
352
353  (define (translate-database db)
354    (cond
355     ((symbol? db)
356      (case db
357        ((first) "!")
358        ((all) "*")
359        (else (complain "Invalid db-placeholder. Must be either of 'all, 'first"))))
360     ((string? db) db)
361     (else (complain "unsopported type for database. Must be either symbol or string" db))))
362
363  (define (translate-strategy strat)
364    (cond
365     ((and (symbol? strat) (eq? strat 'default)) ".")
366     ((string? strat) strat)
367     (else
368      (complain "invalid type for strategy given. Must be either 'default or a string naming the strategy" strat))))
369
370
371  (define (send-command con cmd . args)
372    (unless (connection? con)
373      (complain "supplied arguments is not a valid connection"))
374    (unless (connection-connected con)
375      (complain "not connected"))
376   
377    (let ((port (connection-output-port con)))
378      (dict-log ">>: ")
379      (dict-log cmd)
380      (display cmd port)
381      (for-each (lambda (param)
382                  (dict-log " ")
383                  (dict-log param port)
384                  (display " " port)
385                  (display param port))
386                args)
387      (dict-log "\n")
388      (display +crlf+ port)
389      (flush-output port)))
390
391  (define (issue-command success? proc con cmd . args)
392    (apply send-command con cmd args)
393    (let ((resp (read-status-response (connection-input-port con))))
394      (if (success? resp)
395          (values #t (proc (connection-input-port con)))
396          (values #f resp))))
397 
398  ;;commands follow
399  (define (!match con word #!key (strategy 'default) (db 'first))
400    (let ((strat (translate-strategy strategy))
401          (db (translate-database db)))
402      (issue-command status:n-matches-retrieved? read-matches con +cmd:match+ db strat word)))
403
404  (define (!define con word #!key (db 'first))
405    (let ((db (translate-database db)))
406      (issue-command status:n-definitions-retrieved? read-definitions con +cmd:define+ db word)))
407
408  (define (!databases con)
409    (issue-command status:n-databases-present? read-pairs con +cmd:show-db+))
410 
411
412  (define (!strategies con)
413    (issue-command status:n-strategies-present? read-pairs con +cmd:show-strat+))
414
415
416  (define (!server-information con)
417    (issue-command status:server-information-follows? read-text con +cmd:show-server+))
418
419
420  (define (!database-information con db)
421    (issue-command status:database-information-follows? read-text con +cmd:show-info+ db))
422
423  (define (!help con)
424    (issue-command status:help-text-follows? read-text con +cmd:help+))
425
426  (define (!status con)
427    (send-command con +cmd:status+)
428    (let ((status (read-status-response (connection-input-port con))))
429      (values (status:statistic? status) status)))
430
431  (define (!quit con)
432    (send-command con +cmd:quit+)
433    (let ((status (read-status-response (connection-input-port con))))
434      (values (status:closing-connection? status) status)))
435
436  (define (!announce-client con client)
437    (send-command con +cmd:client+ client)
438    (let ((status (read-status-response (connection-input-port con))))
439      (values (status:ok? status) status)))
440
441  ;;enable this once md5 has been ported to chicken 4
442  ;; (define (!authenticate con username password)
443  ;;   (send-command con +cmd:authenticate+ username (compute-password con password))
444  ;;   (let ((status (read-status-response (connection-input-port con))))
445  ;;     (status:authentication-successful? status)))
446
447  ;; (define (compute-password con password)
448  ;;   (md5:digest (string-append (connection-msg-id con) password)))
449
450
451  (define (connect server #!key (port (*default-port*)) (client "dict.eg for chicken scheme") (timeout #f))
452    (parameterize ((tcp-connect-timeout timeout))
453      (receive (i o) (tcp-connect server port)
454        (let ((status (read-status-response i)))
455          (cond
456           ((status:banner? status)
457            (let* ((banner (parse-banner (response-status-message status)))
458                   (con (make-connection input-port: i
459                                         output-port: o
460                                         connected: #t
461                                         msg-id: (banner-msg-id banner)
462                                         text: (banner-text banner)
463                                         server-capabilities: (banner-capabilities banner))))
464              (!announce-client con client)
465              con))
466           (else
467            (complain "Could not connect to server" status)))))))
468
469  (define (disconnect con)
470    (receive (success? result) (!quit con)
471      (when success?
472        (close-input-port (connection-input-port con))
473        (close-output-port (connection-output-port con))
474        (connection-connected-set! con #f))
475      (not (connection-connected con))))
476)
477;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
478;;; dict.scm ends here
Note: See TracBrowser for help on using the repository browser.