Changeset 36089 in project


Ignore:
Timestamp:
08/10/18 22:13:14 (14 months ago)
Author:
sjamaan
Message:

Port estraier-client to CHICKEN 5

Location:
release/5/estraier-client
Files:
1 added
2 deleted
2 edited
2 copied

Legend:

Unmodified
Added
Removed
  • release/5/estraier-client/trunk/estraier-client.egg

    r36083 r36089  
    55 (category db)
    66 (license "BSD")
    7  (doc-from-wiki)
    8  (needs (http-client 0.2) (uri-common 1.1) intarweb)
    9  (test-depends test))
     7 (dependencies http-client uri-common intarweb)
     8 (test-dependencies test)
     9 (components (extension estraier-client)))
  • release/5/estraier-client/trunk/estraier-client.scm

    r26022 r36089  
    22;; Hyper Estraier client library
    33;;
    4 ; Copyright (c) 2009-2012 Peter Bex
     4; Copyright (c) 2009-2018 Peter Bex
    55; All rights reserved.
    66;
     
    4747   list-nodes add-node delete-node clear-node list-users add-user delete-user)
    4848
    49 (import chicken scheme)
    50 (use data-structures extras ports srfi-1 srfi-13 http-client uri-common intarweb)
     49(import scheme (chicken base) (chicken port) (chicken string)
     50        (chicken condition) (chicken io) (chicken format)
     51        http-client uri-common intarweb)
     52
     53;; Let's not drag in srfi-13
     54(define (string-prefix? s1 s2)
     55  (eqv? 0 (substring-index s1 s2)))
    5156
    5257;; Exhaust input port with web-server's output (yes, confusing) and return void
     
    8994  (let loop ((result (list))
    9095             (line (read-line inport)))
    91     (if (or (eof-object? line) (string-null? line))
    92         (reverse! result)
     96    (if (or (eof-object? line) (string=? "" line))
     97        (reverse result)
    9398        (loop (cons line result) (read-line inport)))))
    9499
    95100(define (split-attrib-line attrib-line)
    96   (let ((idx (string-index attrib-line #\=)))
    97     (cons (string->symbol (string-take attrib-line idx))
    98           (string-drop attrib-line (add1 idx)))))
     101  (let ((idx (substring-index "=" attrib-line)))
     102    (cons (string->symbol (substring attrib-line 0 idx))
     103          (substring attrib-line (add1 idx)))))
    99104
    100105(define (line->node-info line)
    101   (let ((info (string-split line "\t" #t)))
    102     `((name . ,(first info))
    103       (label . ,(second info))
    104       (document-count . ,(string->number (third info)))
    105       (word-count . ,(string->number (fourth info)))
    106       (size . ,(string->number (fifth info))))))
     106  (apply (lambda (name label document-count word-count size)
     107           `((name . ,name)
     108             (label . ,label)
     109             (document-count . ,(string->number document-count))
     110             (word-count . ,(string->number word-count))
     111             (size . ,(string->number size))))
     112         (string-split line "\t" #t)))
    107113
    108114(define (line->user-info line)
     
    117123(define (write-attributes outport attributes)
    118124  (for-each (lambda (attrib)
    119               (fprintf outport "~A=~A\r\n"
    120                        (kill-special-whitespace (->string (car attrib)))
    121                        (kill-special-whitespace (->string (cdr attrib)))))
     125              ;; Writing out @digest would invalidate the document.
     126              (unless (eq? '@digest (car attrib))
     127                (fprintf outport "~A=~A\r\n"
     128                  (kill-special-whitespace (->string (car attrib)))
     129                  (kill-special-whitespace (->string (cdr attrib))))))
    122130            attributes))
    123131
     
    131139
    132140(define (read-attributes inport)
    133   (map split-attrib-line
    134        ;; Remove control commands like %VECTOR for now
    135        (filter (lambda (line)
    136                  (string-index line #\=))
    137                (read-block inport))))
     141  (foldr (lambda (line attrs)
     142           ;; Ignore control commands like %VECTOR for now
     143           (if (substring-index "=" line)
     144               (cons (split-attrib-line line) attrs)
     145               attrs))
     146         '()
     147         (read-block inport)))
    138148
    139149;; Read a document in "draft" format from the specified input port.
     
    205215                 headers: (headers '((content-type text/x-estraier-draft))))
    206216   (call-with-output-string ; use string because it wants content-length
    207      ;; Can't write @digest because that would invalidate the document
    208      (lambda (out) (write-draft out contents (alist-delete '@digest attribs))))
     217     (lambda (out) (write-draft out contents attribs)))
    209218   discard-output))
    210219
     
    240249                 headers: (headers '((content-type text/x-estraier-draft))))
    241250   (call-with-output-string ; use string because it wants content-length
    242      ;; Can't write @digest because that would invalidate the document
    243      (lambda (out) (write-attributes out (alist-delete '@digest attribs))))
     251     (lambda (out) (write-attributes out attribs)))
    244252   discard-output))
    245253
     
    260268                     (keywords (list)))
    261269            (if (eof-object? line)
    262                 (reverse! keywords) ;; preserve keyword document order
     270                (reverse keywords) ;; preserve keyword document order
    263271                (let ((kwd/score (string-split line "\t" #t)))
    264272                  (loop (read-line in)
    265                         (cons (cons (first kwd/score)
    266                                     (string->number (second kwd/score)))
     273                        (cons (cons (car kwd/score)
     274                                    (string->number (cadr kwd/score)))
    267275                              keywords))))))))
    268276
     
    278286                   'args)))
    279287  ;; Normalise attr-phrases list to attr, attr1, ... attr9
    280   (let ((attrs (map (lambda (a i)
    281                       (if (zero? i)
    282                           (cons 'attr a)
    283                           (cons (sprintf "attr~A" i) a)))
    284                     attr-phrases
    285                     (iota 10))))
    286    (apply
    287     values
    288     (exec 'find-documents
    289           (node-uri base-uri node "search"
    290                     query: `((phrase . ,phrase) (order . ,order)
    291                              (max . ,max)       (options . ,options)
    292                              (depth . ,depth)   (wwidth . ,wwidth)
    293                              (hwidth . ,hwidth) (awidth . ,awidth)
    294                              (skip . ,skip)     (mask . ,mask)
    295                              (auxiliary . ,auxiliary)
    296                              (distinct . ,distinct)
    297                              ,@attrs))
    298           #f
    299           (lambda (in)
    300             (let* ((delimiter (read-line in))
    301                    (meta
    302                     (let next-line ((line (read-line in))
    303                                     (metadata (list)))
    304                       ;; There's a pointless blank line at the end... skip over it
    305                       (if (string-null? line)
    306                           (next-line (read-line in) metadata)
    307                           (if (string-prefix? delimiter line)
    308                               (reverse! metadata) ; done, continue to snippets
    309                               (let ((data (string-split line "\t" #t)))
    310                                 (next-line (read-line in)
    311                                            (cons (cons (string->symbol (car data))
    312                                                        (cdr data))
    313                                                  metadata)))))))
    314                    (documents
    315                     (let next-document ((docs (list)))
    316                       (let ((attribs (read-attributes in)))
    317                         (let next-line ((matches (list))
    318                                         (line  (read-line in)))
    319                           (cond
    320                            ;; We're not relying on :END here since it would
    321                            ;; complicate matters with zero search results.
    322                            ((eof-object? line)
    323                             (reverse! docs))
    324                            ((string-prefix? delimiter line)
    325                             (next-document (cons (cons (reverse! matches) attribs)
    326                                                  docs)))
    327                            ;; Discard pointless empty lines.. there's at least
    328                            ;; one at the end of each block.
    329                            ((string-null? line)
    330                             (next-line matches (read-line in)))
    331                            (else
    332                             (let* ((idx (string-index line #\tab))
    333                                    (highlight (and idx (string-take line idx)))
    334                                    (match (if idx
    335                                               (string-drop line (add1 idx))
    336                                               line)))
    337                               (next-line (cons (cons highlight match) matches)
    338                                          (read-line in))))))))))
    339               (list documents meta)))))))
     288  (let next ((i 0)
     289             (attrs '())
     290             (attr-phrases attr-phrases))
     291    (if (pair? attr-phrases)
     292        (let ((name (if (zero? i) 'attr (sprintf "attr~A" i))))
     293          (next (add1 i)
     294                (cons (cons name (car attr-phrases)) attrs)
     295                (cdr attr-phrases)))
     296        (apply
     297         values
     298         (exec 'find-documents
     299               (node-uri base-uri node "search"
     300                         query: `((phrase . ,phrase) (order . ,order)
     301                                  (max . ,max)       (options . ,options)
     302                                  (depth . ,depth)   (wwidth . ,wwidth)
     303                                  (hwidth . ,hwidth) (awidth . ,awidth)
     304                                  (skip . ,skip)     (mask . ,mask)
     305                                  (auxiliary . ,auxiliary)
     306                                  (distinct . ,distinct)
     307                                  ,@attrs))
     308               #f
     309               (lambda (in)
     310                 (let* ((delimiter (read-line in))
     311                        (meta
     312                         (let next-line ((line (read-line in))
     313                                         (metadata (list)))
     314                           ;; There's a pointless blank line at the end... skip over it
     315                           (if (string=? "" line)
     316                               (next-line (read-line in) metadata)
     317                               (if (string-prefix? delimiter line)
     318                                   (reverse metadata) ; done, continue to snippets
     319                                   (let ((data (string-split line "\t" #t)))
     320                                     (next-line (read-line in)
     321                                                (cons (cons (string->symbol (car data))
     322                                                            (cdr data))
     323                                                      metadata)))))))
     324                        (documents
     325                         (let next-document ((docs (list)))
     326                           (let ((attribs (read-attributes in)))
     327                             (let next-line ((matches (list))
     328                                             (line  (read-line in)))
     329                               (cond
     330                                ;; We're not relying on :END here since it would
     331                                ;; complicate matters with zero search results.
     332                                ((eof-object? line)
     333                                 (reverse docs))
     334                                ((string-prefix? delimiter line)
     335                                 (next-document (cons (cons (reverse matches) attribs)
     336                                                      docs)))
     337                                ;; Discard pointless empty lines.. there's at least
     338                                ;; one at the end of each block.
     339                                ((string=? "" line)
     340                                 (next-line matches (read-line in)))
     341                                (else
     342                                 (let* ((idx (substring-index "\t" line))
     343                                        (highlight (and idx (substring line 0 idx)))
     344                                        (match (if idx
     345                                                   (substring line (add1 idx))
     346                                                   line)))
     347                                   (next-line (cons (cons highlight match) matches)
     348                                              (read-line in))))))))))
     349                   (list documents meta))))))))
    340350
    341351(define (_set-user loc base-uri node name mode)
  • release/5/estraier-client/trunk/tests/run.scm

    r33134 r36089  
    11(load "../estraier-client.scm")
    22
    3 (use utils test posix http-client srfi-13)
    4 
    5 (import estraier-client)
     3(import test estraier-client http-client
     4        (chicken condition) (chicken process-context) (chicken string)
     5        (chicken process) (chicken io) (chicken format) (chicken sort))
    66
    77;; Avoid listening on the default estraier port because the main Salmonella
     
    2323 (let* ((contents (with-input-from-file "masterdir/_conf" read-lines))
    2424        (changed-contents (map (lambda (l)
    25                                  (if (string-prefix? "portnum:" l)
     25                                 (if (substring-index "portnum:" l)
    2626                                     (conc "portnum: " server-port) l))
    2727                               contents)))
Note: See TracChangeset for help on using the changeset viewer.