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

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

initial import of rewritten version

File size: 19.6 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:39:41 2009 (CEST)
11;;           By: David Krentzlin <david@lisp-unleashed.de>
12;;     Update #: 438
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  ;;used internally only
208  (define-syntax define-cmd
209    (lambda (exp rename compare)
210      (let* ((cmd (cadr exp))
211             (%define (rename 'define))
212             (cmd-symbol (string->symbol (conc "+cmd:" (string-translate* (string-downcase cmd) '((" " . "-"))) "+"))))
213        `(,%define ,cmd-symbol ,(string-upcase cmd)))))
214
215  (define-cmd "quit")
216  (define-cmd "client")
217  (define-cmd "define")
218  (define-cmd "match")
219  (define-cmd "show strat")
220  (define-cmd "show db")
221  (define-cmd "show info")
222  (define-cmd "show server")
223  (define-cmd "status")
224  (define-cmd "help")
225  (define-cmd "auth")
226  (define-cmd "option mime")
227
228  ;;banner-object
229  (define (make-banner text msg-id cap)
230    (unless (list? cap)
231      (complain "capabilities must be a string"))
232    (unless (and (string? text) (string? msg-id))
233      (complain "text and msg-id must be strings"))
234    (list text msg-id cap))
235
236  (define banner-msg-id cadr)
237  (define banner-text car)
238  (define banner-capabilities caddr)
239
240
241  ;;logging support
242  ;;every command and response will be logged
243  ;;to *current-log-port* if logging is enabled
244  (define *current-log-port* (make-parameter #f))
245
246
247  (define (dict-log  fmt . args)
248    (if (*current-log-port*)
249        (apply fprintf (*current-log-port*) fmt args)
250        #f))
251
252
253  ;;input routines and parsing
254
255  ;;readline with logging
256  ;;and optionally erroring when eof is received
257  (define (dict-read-line port #!optional (eof-is-error? #f))
258    (let ((line (read-line port)))
259      (when (and (eof-object? line) eof-is-error?)
260        (complain "unexpected eof received"))
261      (dict-log "<<: ~A~%" line)
262      line))
263
264
265  ;;parse a status response
266  ;;the rfc states that a legal status response
267  ;;is an integer representing the status-code (optionally with leading zeros)
268  ;;which is optionally followed by textual information
269  (define (parse-status-response input)
270    (let ((eoc (string-skip input char-set:digit)))
271      (cond
272       ((not eoc)   (make-status-response (string->number (string-trim-both (string-trim input #\0) #\space)) ""))
273       ((zero? eoc) (complain "Malformed status response " input))
274       (else        (make-status-response (string->number (string-trim (string-take input eoc) #\0)) (string-drop input (+ 1 eoc)))))))
275
276
277  (define (read-status-response port)
278    (parse-status-response (string-trim (dict-read-line port) #\space)))
279
280  ;;parse the banner status-response
281  ;;the textual information of the banner-status
282  ;;provides addtional information about the server
283  ;;we're interested in the message-id and the list of capabilities
284  (define (parse-banner input)
285    (let ((parts (reverse (string-split-fields "\\s+" input #:infix))))
286      (when (< (length parts) 2)
287        (complain "Malformed banner received"))
288      (let ((msg-id (car parts))
289            (cap (cadr parts)))
290        (if (and (positive? (string-length cap)) (char=? (string-ref cap 0) #\<))
291            (make-banner  (string-join (reverse (cddr parts)) " ")
292                          msg-id
293                          (string-split-fields "\\." (string-trim-right (string-trim cap #\<) #\>) #:infix))
294            (make-banner (string-join (reverse (cdr parts)) " ")
295                         msg-id
296                         '())))))
297
298  ;;input: the textual information of status 151
299  (define (parse-status-151 input)
300    (let ((ws (string-index input #\space)))
301      (unless ws (complain "Malformed status 151 response. Expected `word`" input))
302      (let ((word (string-trim-both (string-take input ws) #\"))
303            (ws2 (string-index input #\space (+ ws 1))))
304        (unless ws (complain "Malformed status 151 response. Expected `databasename`"  input))
305        (let ((db (string-trim-both (string-take (string-drop input (+ ws 1)) (- ws2 (+ 1 ws))) #\"))
306              (descr (string-trim-both (string-trim-both (string-drop input (+ 1 ws2)) #\space) #\")))
307          (list word db descr)))))
308
309  ;;fold input until we reach .\r\n 250 ok\r\n
310  (define (fold-input port knil kons)
311    (let loop ((expect-status? #f) (knil knil))
312      (if expect-status?
313          (let ((status (read-status-response port)))
314            (if (status:ok? status) knil (complain "Unexpected status response. Expected 250 ok" status)))
315          (let ((line (dict-read-line port #t)))
316            (if (string=? (string-trim-both line #\space) ".")
317                (loop #t knil)
318                (loop #f (kons knil line)))))))
319
320  ;;simply consume all text
321  (define (read-text port)
322    (fold-input port "" (cut string-append <> <> "\n")))
323
324
325  ;;consume all input building pairs out of each line
326  ;;used for example for strategy-lists
327  (define (line->pair line)
328    (let ((ws (string-index line #\space)))
329      (list (string-trim-both (string-take line ws) #\space) (string-trim-both (string-trim-both (string-drop line (+ ws 1)) #\space) #\"))))
330
331  (define (read-pairs port)
332    (reverse (fold-input port '() (lambda (lines line) (cons (line->pair line) lines)))))
333
334
335  (define (read-matches port)
336    (fold-input port '() (lambda (matches line)
337                           (let* ((match (line->pair line)))
338                             (alist-update! (car match)
339                                            (cons (cadr match) (alist-ref (car match) matches string-ci=? '()))
340                                            matches string-ci=?)))))
341
342  (define (read-definitions port)
343    (let loop ((expect-status? #t) (wdn '()) (text "") (defs '()))
344      (if expect-status?
345          (let ((status (read-status-response port)))
346            (cond
347             ((status:ok? status) (reverse defs))
348             ((status:word-database-name? status)
349              (loop #f (parse-status-151 (response-status-message status)) text defs))
350             (else (complain "unexpected status response" status))))
351          (let ((line (dict-read-line port #t)))
352            (if (string=? (string-trim-both line #\space) ".")
353                (loop #t '() "" (cons (append wdn (list text)) defs))
354                (loop #f wdn (string-append text line "\n") defs))))))
355 
356  ;;the connection-object
357  (defstruct connection input-port output-port connected msg-id text server-capabilities)
358
359
360  (define (translate-database db)
361    (cond
362     ((symbol? db)
363      (case db
364        ((first) "!")
365        ((all) "*")
366        (else (complain "Invalid db-placeholder. Must be either of 'all, 'first"))))
367     ((string? db) db)
368     (else (complain "unsopported type for database. Must be either symbol or string" db))))
369
370  (define (translate-strategy strat)
371    (cond
372     ((and (symbol? strat) (eq? strat 'default)) ".")
373     ((string? strat) strat)
374     (else
375      (complain "invalid type for strategy given. Must be either 'default or a string naming the strategy" strat))))
376
377
378  (define (send-command con cmd . args)
379    (unless (connection? con)
380      (complain "supplied arguments is not a valid connection"))
381    (unless (connection-connected con)
382      (complain "not connected"))
383   
384    (let ((port (connection-output-port con)))
385      (dict-log ">>: ")
386      (dict-log cmd)
387      (display cmd port)
388      (for-each (lambda (param)
389                  (dict-log " ")
390                  (dict-log param port)
391                  (display " " port)
392                  (display param port))
393                args)
394      (dict-log "\n")
395      (display +crlf+ port)
396      (flush-output port)))
397
398  (define (issue-command success? proc con cmd . args)
399    (apply send-command con cmd args)
400    (let ((resp (read-status-response (connection-input-port con))))
401      (if (success? resp)
402          (values #t (proc (connection-input-port con)))
403          (values #f resp))))
404 
405  ;;commands follow
406  (define (!match con word #!key (strategy 'default) (db 'first))
407    (let ((strat (translate-strategy strategy))
408          (db (translate-database db)))
409      (issue-command status:n-matches-retrieved? read-matches con +cmd:match+ db strat word)))
410
411  (define (!define con word #!key (db 'first))
412    (let ((db (translate-database db)))
413      (issue-command status:n-definitions-retrieved? read-definitions con +cmd:define+ db word)))
414
415  (define (!databases con)
416    (issue-command status:n-databases-present? read-pairs con +cmd:show-db+))
417 
418
419  (define (!strategies con)
420    (issue-command status:n-strategies-present? read-pairs con +cmd:show-strat+))
421
422
423  (define (!server-information con)
424    (issue-command status:server-information-follows? read-text con +cmd:show-server+))
425
426
427  (define (!database-information con db)
428    (issue-command status:database-information-follows? read-text con +cmd:show-info+ db))
429
430  (define (!help con)
431    (issue-command status:help-text-follows? read-text con +cmd:help+))
432
433  (define (!status con)
434    (send-command con +cmd:status+)
435    (let ((status (read-status-response (connection-input-port con))))
436      (values (status:statistic? status) status)))
437
438  (define (!quit con)
439    (send-command con +cmd:quit+)
440    (let ((status (read-status-response (connection-input-port con))))
441      (values (status:closing-connection? status) status)))
442
443  (define (!announce-client con client)
444    (send-command con +cmd:client+ client)
445    (let ((status (read-status-response (connection-input-port con))))
446      (values (status:ok? status) status)))
447
448  ;;enable this once md5 has been ported to chicken 4
449  ;; (define (!authenticate con username password)
450  ;;   (send-command con +cmd:authenticate+ username (compute-password con password))
451  ;;   (let ((status (read-status-response (connection-input-port con))))
452  ;;     (status:authentication-successful? status)))
453
454  ;; (define (compute-password con password)
455  ;;   (md5:digest (string-append (connection-msg-id con) password)))
456
457
458  (define (connect server #!key (port (*default-port*)) (client "dict.eg for chicken scheme") (timeout #f))
459    (parameterize ((tcp-connect-timeout timeout))
460      (receive (i o) (tcp-connect server port)
461        (let ((status (read-status-response i)))
462          (cond
463           ((status:banner? status)
464            (let* ((banner (parse-banner (response-status-message status)))
465                   (con (make-connection input-port: i
466                                         output-port: o
467                                         connected: #t
468                                         msg-id: (banner-msg-id banner)
469                                         text: (banner-text banner)
470                                         server-capabilities: (banner-capabilities banner))))
471              (!announce-client con client)
472              con))
473           (else
474            (complain "Could not connect to server" status)))))))
475
476  (define (disconnect con)
477    (receive (success? result) (!quit con)
478      (when success?
479        (close-input-port (connection-input-port con))
480        (close-output-port (connection-output-port con))
481        (connection-connected-set! con #f))
482      (not (connection-connected con))))
483)
484;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
485;;; dict.scm ends here
Note: See TracBrowser for help on using the repository browser.