;; (C) 2002, 2003 Joerg F. Wittenberger see http://www.askemos.org

;; TODO overwrite chicken'S port redirection code with more
;; restrictive versions.  See chicken mailing list 1-3 Mar 2003.

(declare
 (unit util)
 (uses srfi-1 srfi-13 srfi-18 srfi-19 posix files utils library extras regex tcp)
 (import "srfi19.scm" "openssl.scm")
 (fixnum-arithmetic)
 (not usual-integrations raise signal error current-exception-handler)
 (export				; internals to be avoided if possible
  ##process#io-ports
  close-all-ports-except)
 (export
  make-condition-type condition-type? condition-type-name
  make-condition condition? condition-has-type?
  condition-ref make-compound-condition extract-condition
  &condition &message message-condition? condition-message
  &serious serious-condition? &error error?
  type-field-alist->condition check-condition-type-field-alist)
 (export
  register-blob-ref! unregister-blob-ref! non-transient-blob?
  with-exception-guard raise signal error abort ##sys#error ##sys#signal
  current-exception-handler with-exception-handler

  monitor-value
  combine list->values arithmetic-shift-right arithmetic-shift-left
  remove-file file-directory? dirname scandir remove-dir remove-dir-recursive link
  cwd file-empty? file->string filedata filesystem-free find-in-path
  mkdirs within-directory make-temporary-directory call-with-temporary-directory
  sudo!
  thread-list thread-sleep!/ms thread-deliver-signal!
  read-bytes string-splice!
  string-prefix-length+
  not-eof-object? read-all-expressions
  askemos:run-tcp-server askemos:run-tcp-client
  process-kill
  *set-child-uid* run-child-process make-process-stub
  ;;
  condition->fields condition->fields+
  ;;
  ;; regex
  ;;
  reg-expr->proc
  has-suffix?
  content-type-charset xml-pi-regex xml-pi-encoding
  html-regex
  is-proxy-request? ip-addr-regex
  http-prefix? http-is-login? http-is-logout? http-is-post-url? http-is-check-url?
  http-cmd-regex http-status-regex split-url-regex http-location-regex
  lmtp-from-regex lmtp-destination-email-regex
  html-only-client
  string-split-last to-string
  broken-303-client user-agent-ie user-agent-amaya user-agent-mozilla
  nunu-regexp nunu-include-regexp bold-regexp url-regexp nunu-oid-regexp
  sql-quote colon-split-regex
  ;;
  strip-html-suffix
  colon-split
  sql-quote
  lout-collapsable-whitespace-sequence-regexp illegal-lout?
  lout-literal-char-sequence-regexp
  ;;
  ;; general
  ;;
  bind-exit call-with-list-extending call-with-list-extending1
  logit logerr logcond logcond-full logcond-short log-condition
  debug user-debug
  hash-table->key-vector key-sequence count-keys
  dsssl:time to-string* ;; timestamp ; moved to timeout.scm
  map-matches-alternate
  ;;
  rfc-822-time-string-format rfc-822-timestring timezone-offset
  iso-8601-time-string-format iso-8601-timestring
  ;;
  oid? oid=? make-oid-table make-oid
  make-symbol-table make-string-table make-fixnum-table make-character-table
  ;;
  make-semaphore semaphore? semaphore-value
  semaphore-wait-by! semaphore-signal-by!
  semaphore-name
  mutex-owner
  make-mailbox mailbox? mailbox-empty? mailbox-clone mailbox-has-message?
  send-message! receive-message! receive-message-if-present!
  mailbox-drop-matching!
  mailbox-number-of-items		; avoid!
  thunk->future future?
  register-location-format!
  read-locator write-locator
  location-format ;; FIXME, should not be exported.

  ;;
  reset-trustedcode! register-trustedcode! get-trusted-code
  pilot-makedoc with-output-through-lout with-output-through-htmldoc
  ;;
  ;; strings
  ;;
  string-replw string-left string-right
  apply-string-append srfi:string-join
  ;;
  ;; config
  local-id
  ;; Storage Adaptor and their configuration
  ;; HTTP protocol variables
  $client-lookups?
  )
 (foreign-declare #<<EOF

#include <time.h>

static void A_addstr5(C_word c, C_word self, C_word k,
                      C_word s_buf, C_word s_i, C_word s_str, C_word s_j,
                      C_word s_flush) C_noret;

static void A_addstr5(C_word c, C_word self, C_word k,
                      C_word s_buf, C_word s_i, C_word s_str, C_word s_j,
                      C_word s_flush)
{
  int i = C_unfix(s_i), j = C_unfix(s_j);
                         /* string-length coded inline */
  unsigned int buf_max = C_header_size(s_buf) - i;
  unsigned int str_max = C_header_size(s_str) - j;
  unsigned int n = buf_max < str_max ? buf_max : str_max;

  register C_char *buf = (C_char *)C_data_pointer(s_buf) + i;
  register C_char *str = (C_char *)C_data_pointer(s_str) + j;
  register C_char *end = str + n;

  while(str != end) *buf++=*str++;
  i += n;
  if( n == buf_max )
    /* end recursive call of s_flush; self is the current closure */
    ((C_proc7)C_retrieve_proc(s_flush))
     (7, s_flush, k, s_buf, C_fix(i), s_str, C_fix(j + n), self);
    C_kontinue(k, C_fix(i));  /* call the current continuation */
}
EOF
)
 )

;(define-library-implementation util
; ;(import scheme chicken-unistd chicken-regex srfi-18)
; (export
;  remove-file dirname file-empty? filedata
;  timestamp read-bytes
;  reg-expr->proc
;  http-prefix? http-is-login? http-is-logout? http-is-post-url?
;  multipart-data-boundary content-disposition->name-regex
;  message-body-offset-regex mime-boundary lws-suffix
;  html-only-client broken-303-client user-agent-ie
;  nunu-regexp nunu-include-regexp bold-regexp url-regexp
;  sql-special-regexp colon-split-regex

;  bind-exit
;  logit logerr default-log-access log-access debug
;  filter to-string*
;  map-matches-alternate
;  oid? oid->hash make-oid-table make-oid

;  expect-object read-all
;  register-location-format!
;  read-locator write-locator

;  nunu-owner

;  iso-timestring rfc-822-timestring

;  strip-html-suffix content-disposition->name message-body-offset
;  addlws-suffix-len rfc2046-split colon-split
;  string-quote

;  register-trustedcode! get-trusted-code
;  pilot-makedoc with-output-through-lout with-output-through-htmldoc

;  ))

;(include "srfi34-syntax.scm")

;; REPLACE THE EXCEPTION HANDLER

;; unsure, shouldn't we wrap the handler with dynamic-wind ?

(define chicken-exception-handler (current-exception-handler))

(define srfi34:*current-exception-handlers*
  (make-parameter (list chicken-exception-handler)))

(define (srfi34:with-exception-handler handler thunk)
  (srfi34:with-exception-handlers
   (cons handler (srfi34:*current-exception-handlers*))
   thunk))

(define (srfi34:with-exception-handlers new-handlers thunk)
  (let ((previous-handlers (srfi34:*current-exception-handlers*)))
    (dynamic-wind
      (lambda ()
        (srfi34:*current-exception-handlers* new-handlers))
      thunk
      (lambda ()
        (srfi34:*current-exception-handlers* previous-handlers)))))

(define (srfi34:raise obj)
  (let ((handlers (srfi34:*current-exception-handlers*)))
    (srfi34:with-exception-handlers (cdr handlers)
      (lambda ()
        ((car handlers) obj)
        ;; (error "handler returned" (car handlers) obj)
        (chicken-exception-handler
         (make-property-condition
          'exn 'message "exception handler returned"))))))

(set! with-exception-handler srfi34:with-exception-handler)

(set! current-exception-handler
      (lambda () (car (srfi34:*current-exception-handlers*))))

(set! ##sys#default-exception-handler current-exception-handler)

; (define (##sys#escape x)
;   (let ((handler-chain ##sys#current-exception-handler))
;     (set! ##sys#current-exception-handler
;           (cdr ##sys#current-exception-handler))
;     ((car handler-chain) x)
;     (set! ##sys#current-exception-handler handler-chain)))

;(define srfi-34:raise ##sys#escape)

(set! ##sys#abort
      (lambda (x)
        ((current-exception-handler) x)
        (##sys#abort (make-property-condition
                      'exn 'message "exception handler returned")) ))

(set! ##sys#signal
      (lambda (x)
        ((current-exception-handler) x)) )

(set! ##sys#current-exception-handler current-exception-handler)

(define raise srfi34:raise)
(set! abort ##sys#abort)
(set! signal ##sys#signal)
(set! error
      (lambda (msg . args)
        (raise (if (pair? args) (format #f "~a ~s" msg args) msg))))

(set! ##sys#error error)

; (set! ##sys#current-exception-handler
;       (list ##sys#current-exception-handler))

; (set! with-exception-handler
;       (lambda (handler thunk)
;         (let ((handler-chain ##sys#current-exception-handler))
;           (##sys#dynamic-wind
;            (lambda () (set! ##sys#current-exception-handler
;                             (cons handler handler-chain)))
;            thunk
;            (lambda () (set! ##sys#current-exception-handler handler-chain)) ))) )

;; SRFI 34 support

(define (with-exception-guard handler thunk)
  ((call-with-current-continuation
    (lambda (return)
      (srfi34:with-exception-handler
       (lambda (condition)
         ((call-with-current-continuation
           (lambda (handler-k)
             (return (lambda ()
                       (srfi34:with-exception-handler
                        (lambda (condition) (handler-k (lambda () (srfi34:raise condition))))
			(lambda () (handler condition)))))))))
       (lambda ()
         (##sys#call-with-values
          thunk
          (lambda args
            (return (lambda () (##sys#apply ##sys#values args)))) ) ) ) ) )) )


;; SRFI 35 reference implementation
(define-record-type :condition-type
  (really-make-condition-type name supertype fields all-fields)
  condition-type?
  (name condition-type-name)
  (supertype condition-type-supertype)
  (fields condition-type-fields)
  (all-fields condition-type-all-fields))

(define (make-condition-type name supertype fields)
  (if (not (symbol? name))
      (error "make-condition-type: name is not a symbol"
             name))
  (if (not (condition-type? supertype))
      (error "make-condition-type: supertype is not a condition type"
             supertype))
  (if (not
       (null? (lset-intersection eq?
                                 (condition-type-all-fields supertype)
                                 fields)))
      (error "duplicate field name" ))
  (really-make-condition-type name
                              supertype
                              fields
                              (append (condition-type-all-fields supertype)
                                      fields)))
(define (condition-subtype? subtype supertype)
  (let recur ((subtype subtype))
    (cond ((not subtype) #f)
          ((eq? subtype supertype) #t)
          (else
           (recur (condition-type-supertype subtype))))))

(define (condition-type-field-supertype condition-type field)
  (let loop ((condition-type condition-type))
    (cond ((not condition-type) #f)
          ((memq field (condition-type-fields condition-type))
           condition-type)
          (else
           (loop (condition-type-supertype condition-type))))))

; The type-field-alist is of the form
; ((<type> (<field-name> . <value>) ...) ...)
(define-record-type :condition
  (really-make-condition type-field-alist)
  condition?*
  (type-field-alist condition-type-field-alist))

(define condition?
  (let ((orig condition?))
    (lambda (obj) (or (condition?* obj) (orig obj)))))

(define (make-condition type . field-plist)
  (let ((alist (let label ((plist field-plist))
                 (if (null? plist)
                            '()
                     (cons (cons (car plist)
                                 (cadr plist))
                           (label (cddr plist)))))))
    (if (not (lset= eq?
                    (condition-type-all-fields type)
                    (map car alist)))
        (error "condition fields don't match condition type"))
    (really-make-condition (list (cons type alist)))))

(define (condition-has-type? condition type)
  (and (condition?* condition)
       (any (lambda (has-type)
	      (condition-subtype? has-type type))
	    (condition-types condition))))

(define (condition-ref condition field)
  (type-field-alist-ref (condition-type-field-alist condition)
                        field))

(define (type-field-alist-ref type-field-alist field)
  (let loop ((type-field-alist type-field-alist))
    (cond ((null? type-field-alist)
           (error "type-field-alist-ref: field not found"
                  type-field-alist field))
          ((assq field (cdr (car type-field-alist)))
           => cdr)
          (else
           (loop (cdr type-field-alist))))))

(define (make-compound-condition condition-1 . conditions)
  (really-make-condition
   (apply append (map condition-type-field-alist
                      (cons condition-1 conditions)))))

(define (extract-condition condition type)
  (let ((entry (find (lambda (entry)
                              (condition-subtype? (car entry) type))
                            (condition-type-field-alist condition))))
    (if (not entry)
        (error "extract-condition: invalid condition type"
                      condition type))
    (really-make-condition
      (list (cons type
                  (map (lambda (field)
                         (assq field (cdr entry)))
                       (condition-type-all-fields type)))))))

(define (type-field-alist->condition type-field-alist)
  (really-make-condition
   (map (lambda (entry)
          (cons (car entry)
                (map (lambda (field)
                       (or (assq field (cdr entry))
                           (cons field
                                 (type-field-alist-ref type-field-alist field))))
                     (condition-type-all-fields (car entry)))))
        type-field-alist)))

(define (condition-types condition)
  (if (condition?* condition)
      (map car (condition-type-field-alist condition))
      '()))

(define (check-condition-type-field-alist the-type-field-alist)
  (let loop ((type-field-alist the-type-field-alist))
    (if (not (null? type-field-alist))
        (let* ((entry (car type-field-alist))
               (type (car entry))
               (field-alist (cdr entry))
               (fields (map car field-alist))
               (all-fields (condition-type-all-fields type)))
          (for-each (lambda (missing-field)
                      (let ((supertype
                             (condition-type-field-supertype type missing-field)))
                        (if (not
                             (any (lambda (entry)
                                    (let ((type (car entry)))
                                      (condition-subtype? type supertype)))
                                  the-type-field-alist))
                            (error "missing field in condition construction"
                                   type
                                   missing-field))))
                    (lset-difference eq? all-fields fields))
          (loop (cdr type-field-alist))))))

(define &condition (really-make-condition-type '&condition
                                               #f
                                               '()
                                               '()))

(define-condition-type &message &condition
  message-condition?
  (message condition-message))

(define-condition-type &serious &condition serious-condition?)

(define-condition-type &error &serious error?)

(define (key-sequence table) (hash-table-fold cons '() table))

(define process-kill process-signal)

;; process i/o
(define-constant buffer-size 1024)

(define (yield)
  (##sys#call-with-current-continuation
   (lambda (return)
     (let ((ct ##sys#current-thread))
       (##sys#setslot ct 1 (lambda () (return (##core#undefined))))
       (##sys#schedule) ) ) ) )

(set-signal-handler! signal/pipe #f)

(define (close-all-ports-except . ports)
  (do ((i 0 (add1 i)))
      ((eqv? i 1024) #t)
    (if (not (memv i ports))
        ((foreign-lambda* int ((int fd)) "return(close(fd));") i))))

(define-macro (end-of-file) #!eof)

(define ##process#io-ports
  (let ([make-input-port make-input-port]
	[make-output-port make-output-port] 
	[make-string make-string] 
	[substring substring] )
    (lambda (pid fdr fdw)
      (let* ([buf (make-string buffer-size)]
	     ;; [data (vector #f #f #f)]
	     [buflen 0]
	     [bufindex 0]
	     [iclosed #f] 
	     [oclosed #f]
	     [in
	      (make-input-port
	       (lambda ()
		 (when (fx>= bufindex buflen)
		   (##sys#thread-block-for-i/o! ##sys#current-thread fdr #t)
		   (yield)
		   (let ([n ((foreign-lambda*
                              int
                              ((int fd) (pointer buf) (int s))
                              "return(read(fd, buf, s));")
                             fdr buf buffer-size)])
		     (when (eq? -1 n)
		       (##sys#update-errno)
		       (##sys#signal-hook #:process-error "can not read from fd" fdr) )
		     ;; (print "[rd: " n "]")
		     (set! buflen n)
		     (set! bufindex 0) ) )
		 (if (fx>= bufindex buflen)
		     (end-of-file)
		     (let ([c (##core#inline "C_subchar" buf bufindex)])
		       (set! bufindex (fx+ bufindex 1))
		       c) ) )
	       (lambda ()
                 (when iclosed
                   (##sys#signal-hook #:process-error "input port is closed" fdr))
		 #t )
	       (lambda ()
		 (unless iclosed
		   (set! iclosed #t)
		   (when (eq? -1 (file-close fdr))
		     (##sys#update-errno)
		     (##sys#signal-hook #:process-error
                                        "can not close fd input port" fdr) )
                   (when oclosed
                         (receive (p f s) (process-wait pid #f) s))
		    ) ) ) ]
	     [out
	      (make-output-port
	       (lambda (s)
		 (let ([len (##sys#size s)])
		   (let loop ()
		     (let ([n ((foreign-lambda*
                                int
                                ((int fd) (pointer buf) (int count))
                                "return(write(fd, buf, count));") fdw s len)])
		       (cond [(eq? -1 n)
			      (##sys#update-errno)
			      (##sys#signal-hook
                               #:process-error "can not write to fd" fdw len) ]
			     [(fx< n len)
			      (set! s (substring s 0 n))
			      (set! len (fx- len n))
			      (loop) ] ) ) ) ) )
	       (lambda ()
		 (unless oclosed
		   (set! oclosed #t)
		   (when (eq? -1 (file-close fdw))
		     (##sys#update-errno)
		     (##sys#signal-hook #:process-error
                                        "can not close fd output port" fdw) )
                   (when iclosed
                         (receive (p f s) (process-wait pid #f) s))) ) ) ] )
;	(##sys#setslot (##sys#port-data in) 0 data)
;	(##sys#setslot (##sys#port-data out) 0 data)
        (set-finalizer! in (lambda (port) (close-input-port port)))
        (set-finalizer! out (lambda (port) (close-output-port port)))
	(values in out) ) ) ) )

(define (make-user-process-stub runuser thunk dir . env)
  ;; FIXME 'env' and 'dir' not yet used
  (receive (tr tw) (create-pipe)
	   (receive (fr fw) (create-pipe)
		    (let ((pid (process-fork)))
		      (if (eqv? pid 0)
			  (begin
			    (sudo! runuser)
			    ;; (file-close cr) (file-close cw)
			    (duplicate-fileno tr 0)
			    (duplicate-fileno fw 1)
			    (close-all-ports-except 0 1 2)
			    (thunk)
			    (_exit 0))
			  (begin
			    (file-close tr) (file-close fw)
			    (receive (in out) (##process#io-ports pid fr tw)
				     (values pid out in))))))))

(define (make-process-stub args dir . env)
  (apply make-user-process-stub #f
	 (lambda () ((debug 'glaubichnicht process-execute) (car args) (cdr args))) dir env))

(define (sudo! runuser)
  (and-let* ((runuser)
	     (ui (user-information runuser))
	     (user-id (list-ref ui 2))
	     (cu (current-user-id))
	     ((not (eqv? cu user-id)))
	     (g (list-ref ui 3)))
	    (if (eqv? cu 0)
		(initialize-groups runuser g))
	    (set! (current-group-id) g)
	    (set! (current-user-id) user-id)
	    #t))

(define find-in-path
  (let ((*path* #f)
	(pathsep "/")			; FIXME integrate with OS path separator
	[getenv getenv]
	[string-split string-split]
	[string-append string-append]
	[file-execute-access? file-execute-access?])
    (lambda (name)
      (if (not *path*)
	  (set! *path* (string-split (getenv "PATH") ":")))
      (let loop ((p *path*))
	(if (null? p)
	    (error "~a: could not find along PATH" name)
	    (let ((t (string-append (car p) pathsep name)))
	      (if (file-execute-access? t)
		  t
		  (loop (cdr p)))))))))

;;* Crude thing:

(define srfi:string-join string-join)

;;* bind-exit

(define bind-exit call-with-current-continuation)

;;* File System Access

(define file-directory? stat-directory?)
(define remove-file delete-file)
(define remove-dir delete-directory)

(define (remove-dir-recursive dir)
  (define (string->dir s) (string-split s "/"))
  (let ((path (string->dir dir)))
    (do ((f (directory dir) (cdr f)))
        ((null? f) (remove-dir dir))
      (if (not (or (string=? (car f) ".") (string=? (car f) "..")))
          (let ((fullname (make-absolute-pathname path (car f))))
            (if (file-directory? fullname)
                (remove-dir-recursive fullname)
                (remove-file fullname)))))))

(define (link old new)
  ((foreign-lambda* int ((c-string old) (c-string new))
                    "return(link(old, new));") old new))

(define cwd current-directory)

(define scandir directory)

(define (dirname fn)
  (receive (dir name ext) (decompose-pathname fn) dir))
(define (mkdirs path)
  (if (not (file-exists? path))
      (begin
        (mkdirs (pathname-directory path))
        (create-directory path))))

(define (within-directory dir thunk)
  (let ((here #f))
    (dynamic-wind
	(lambda ()
	  (set! here (current-directory))
	  (change-directory dir))
	thunk
	(lambda () (change-directory here)))))

(define (call-with-temporary-directory proc)
  (let ((dir (make-temporary-directory)))
    (if (file-exists? dir)
        (call-with-temporary-directory proc)
        (let ((here #f))
	  (mkdirs dir)
	  (let ((v (dynamic-wind
		       (lambda ()
			 (set! here (current-directory))
			 (or (change-directory dir) (error "can't switch to ~a" dir)))
		       (proc dir)
		       (lambda () (change-directory here)))))
	    (remove-dir-recursive dir)
	    v)))))

(define (file-empty? name)
  (let ((len (file-size name)))
    (and len (eqv? len 0))))

;(define (file->string filename)
;  (read-string (file-size filename) (open-input-file filename)))

;; KLUDGE! This should actually be done with mmap(2).  Chicken can!

(define (filedata name)
  (let* ((s (file-size name))
         (l (or s (error (string-append "No file: " name))))
         (result (make-string l))
         (fd (file-open name (bitwise-ior open/rdonly))))
    (file-read fd l result)
    (file-close fd)
    result))

(define file->string filedata)

;; We need to watch for tight disk space at the file system where 'nm'
;; lives.

(define (filesystem-free nm)
;  (define df-block-regex (reg-expr->proc '(seq (prefix (* (not space)))
;                                               (+ space)
;                                               (let blocks (+ digit))
;                                               (+ space)
;                                               (let used (+ digit))
;                                               (+ space)
;                                               (let avail (+ digit))
;                                               (+ any))))
;  (bind ((df (open-input-process
;              (string-append "/bin/df -kP " nm)))
;         (s e b u a (begin (read-line df)
;                           (df-block-regex (read-line df)))))
;        (close-input-port df)
;        (string->number a))
  1e8)

(define (thread-list)
  (for-each
   (lambda (t) (print (thread-name t) ": " (thread-state t)))
   (##sys#all-threads)))

(define (thread-sleep!/ms ms)
  (thread-sleep! (milliseconds->time (+ ms (current-milliseconds)))))

(define thread-deliver-signal! thread-signal!)

(define-macro (pipe) `(create-pipe))

(define-macro (open-queued-output fd) `(open-output-file* ,fd))

(define-macro (open-mbox-input-port fd) `(open-input-file* ,fd))


(define (combine . fns) (apply compose (reverse fns)))

(define (list->values . args) (apply values args))

(define arithmetic-shift-right arithmetic-shift)
(define (arithmetic-shift-left i n) (arithmetic-shift i (fx* -1 n)))

;; time as defined by dsssl 10.???


(define dsssl:time current-seconds)

;; timezone-offset should actually store the ready made scheme number,
;; not the C number in 'result'.
(define (timezone-offset)
  ((foreign-lambda* integer () #<<EOF
 static int init=0;
 static int result = 0;
 if( !init ) {
   time_t n0 = time(NULL);
   struct tm * now =localtime(&n0);
   result = (now != NULL) ? now->tm_gmtoff : 0;
   init=1;
 }
 return(result);
EOF
)))


;;;*** Object IDentifiers

;(define-class <oid> (<object>)
;  (string-data))

;; (define-generic string-data)

;(define-method (string-data (obj <object>))
;  (slot-ref obj 'string-data))

;;** Utilities for protocol implementations.

(define-macro (hostname) '(get-host-name))

;; read n bytes from port, return as string

(define read-bytes read-string)

(define string-splice! (##core#primitive "A_addstr5"))

;(define (string-splice! buf i str j continue)
;  (let* ((n (min (fx- (string-length str) j)
;                 (fx- (string-length buf) i)))
;         (i2 (fx+ i n)))
;    (##sys#copy-bytes str buf j i n)
;;      ((foreign-lambda*
;;        void
;;        ((c-string str) (c-string buf) (integer j) (integer i) (integer n))
;;        "++n; str+j-1; buf+i-1; while( --n ) *++buf=*++str;") str buf j i n)
;    (if (eq? i2 (string-length buf))
;        (continue buf i2 str (fx+ j n) string-splice!)
;        i2)))

;    (define (addstr buf i str j flush)
;      (let ((str-len (string-length str)))
;        (do ((j j (fx+ j 1))
;             (i i (fx+ i 1)))
;            ((or (eq? i $buffer-size) (eq? j str-len))
;             (if (eq? i $buffer-size) (flush buf i str j addstr) i))
;          ;; chicken for (string-set! buf i (string-ref str j))
;          (##core#inline "C_setsubchar" buf i (##core#inline "C_subchar" str j)))))

(define exn? (condition-predicate 'exn))
(define exn-message (condition-property-accessor 'exn 'message))
(define exn-arguments (condition-property-accessor 'exn 'arguments))

(define (condition->fields ex)
  (cond
    ((and (condition? ex) (exn? ex))
     (values "exception" (exn-message ex) (exn-arguments ex) '()))
    ((uncaught-exception? ex)
     (condition->fields (uncaught-exception-reason ex)))
    ((join-timeout-exception? ex)
     (values "time out" "join-timeout-exception" '() '()))
    (else (values "unknown exception" (format #f "~s" ex) '() '()))))

(define (condition->fields+ ex)
  (let* ((ex (let loop ((ex ex))
	      (or (and (uncaught-exception? ex)
		       (loop (uncaught-exception-reason ex)))
		  ex))))
  (cond
   ((message-condition? ex)
    (values 
     (condition-message ex)
     (call-with-output-string (lambda (port) (write ex port)))
     '()
     '()))
;   ((eof-condition? ex)
;    (values "eof-condition" (eof-condition-reason ex) (or s '()) '()))
    ((and (condition? ex) (exn? ex))
     (values "exception" (exn-message ex) (exn-arguments ex) '()))
    ((join-timeout-exception? ex)
     (values "time out" "join-timeout-exception" '() '()))
    (else (values "unknown exception" (format #f "~s" ex) '() '())))))

;; TODO Conditions might be better off at a central point.

(define $client-lookups? #f)

;; own socket interface

(define (askemos:run-tcp-server
         host port connection-handler
         maximum-semaphore name)
  (define request-queue (tcp-listen port))
  (define (exception-handler ex)
    (receive
     (title msg args rest) (condition->fields ex)
     (logerr "run-tcp-server (host ~a port ~a) ~a ~a ~a\n"
             host port title msg args)))
  (let loop ()
    (handle-exceptions
     ex (exception-handler ex)
     (receive
      (in-port out-port) (tcp-accept request-queue)
      (receive
       (local remote) (tcp-addresses out-port)
       (if maximum-semaphore (semaphore-wait-by! maximum-semaphore 1))
       (thread-start!
        (make-thread
         (lambda ()
           (handle-exceptions
            ex (exception-handler ex)
            (connection-handler in-port out-port remote)
            (if maximum-semaphore (semaphore-signal-by! maximum-semaphore 1))
            (close-input-port in-port)
            (handle-exceptions
             ex (exception-handler ex) (close-output-port out-port))))
           name))))
       (loop))))

(define (close-ports return exception-handler in out)
  (close-input-port in)
  (with-exception-handler
   (lambda (ex) (exception-handler ex) (return ex))
   (lambda () (close-output-port out))))

(define (askemos:run-tcp-client host port connection-handler)
  (define (exception-handler ex)
    (receive
     (title msg args rest) (condition->fields ex)
     (logerr "run-tcp-client (host ~a port ~a) ~a ~a ~a\n"
             host port title msg args)))
  (bind-exit
   (lambda (return)
     (with-exception-handler
      (lambda (ex) (exception-handler ex) (return ex))
      (lambda ()
        (receive
         (in out) (tcp-connect host port)
         (with-exception-handler
          (lambda (ex)
            (return (close-ports return exception-handler in out)))
          (lambda ()
            (connection-handler in out)
            (close-ports return exception-handler in out)))))))))


(define (reg-expr->proc regex)
  (let ((match (regexp regex)))
    (lambda (str . off)
      (let ((result (apply string-match-positions match str off)))
        (if result
            (apply values
                   (caar result) (cdar result)
                   (map (lambda (p) (and p (substring str (car p) (cadr p))))
                        (cdr result)))
            #f)))))

(define gpg-verify-regex
  (let ((match (regexp "gpg: Good signature")))
    (lambda (str) (string-match-positions match str))))

(define strip-html-suffix-regex
  (let ((match (regexp "^(.*)\\.[xX]?[hH][tT][mM][lL]$")))
    (lambda (str . off)
      (let ((result (apply string-match-positions match str off)))
        (if result
            (apply values
                   (caar result) (cdar result)
                   (map (lambda (p) (and p (substring str (car p) (cadr p))))
                        (cdr result)))
            (values #f #f #f))))))

(define http-prefix?
  (let ((match (regexp "^http://|https://")))
    (lambda (str) (and (string-match-positions match str) #t))))

(define content-type-charset
  (let ((match (regexp "^[^;]+;[[:space:]]*charset[[:space:]]*=([^ ]+)|'([^']*)'|\"([^\"]*)\"")))
    (lambda (str)
      (and-let* ((r (string-match-positions match str)))
		(or (cadr r) (caddr r) (list-ref r 3 r))))))

(define xml-pi-encoding
  (let ((match (regexp "^[[:space::]]*version[[:space:]]*=[[:space:]]*'([^']*)'|\"([^\"]*)\"[[:space:]]*encoding[[:space:]]*=[[:space:]]*'([^']*)'|\"([^\"]*)\"")))
    (lambda (str)
      (and-let* ((r (string-match-positions match str)))
		(or (cadddr r) (list-ref r 3 r))))))

(define xml-pi-regex
  (let ((match (regexp "^<\\?xml")))
    (lambda (str) (and (string-match-positions match str) #t))))

(define html-regex
  (let ((match (regexp "^[[:space:]\\n\\r]*(:<!--[^-]-->)?<(:html)|(:HTML)")))
    (lambda (str) (and (string-match-positions match str) #t))))

(define is-proxy-request?
  (let ((match (regexp "^http://|https://|ftp://|ldap://")))
    (lambda (str) (and (string-match-positions match str) #t))))

(define ip-addr-regex
  (regexp "^[[:digit:]]+\\.[[:digit:]]+\\.[[:digit:]]+\\.[[:digit:]]+$"))

(define http-is-login?
  (let ((match (regexp "^/LOGIN")))
    (lambda (str) (and (string-match-positions match str) #t))))

(define http-is-logout?
  (let ((match (regexp "^/LOGOUT")))
    (lambda (str) (and (string-match-positions match str) #t))))

(define http-is-post-url?
  (let ((match (regexp "^/POST(:=[^/]+)?(.*)")))
    (lambda (str)
      (let ((result (string-match-positions match str)))
	(and result (cadr result))))))

(define http-is-check-url?
  (let ((match (regexp "^/CHECK")))
    (lambda (str) (and (string-match-positions match str) #t))))

;; for http server command parsing only
(define http-cmd-regex
  (reg-expr->proc
   "^([[:upper:]]+)[[:blank:]]+([^[:blank:]]+)[[:blank:]](.*)$"))

(define http-status-regex
  (let ((match (regexp (string-append "HTTP/1\\.[01][[:blank:]]+"
                                      "([[:digit:]][[:digit:]][[:digit:]])"
                                      "[[:blank:]]+(.*)$"))))
    (lambda (str)
      (let ((result (string-match-positions match str)))
        (if result
            (apply values
                   (caar result) (cdar result)
                   (map (lambda (p) (and p (substring str (car p) (cadr p))))
                        (cdr result)))
            (values #f #f #f #f))))))

(define http-location-regex
  (let ((match (regexp (string-append "(https?://)([^/]*)(.*)$"))))
    (lambda (str)
      (let ((result (string-match-positions match str)))
        (if result
            (apply values
                   (caar result) (cdar result)
                   (map (lambda (p) (and p (substring str (car p) (cadr p))))
                        (cdr result)))
            (values #f #f #f #f #f))))))

(define split-url-regex
  (let ((match (regexp (string-append "http://([^:/]+):([^/]+)@"
                                      "([^:/]+)(:([^/]+))?/(.*)"))))
    (lambda (str . off)
      (let ((result (apply string-match-positions match str off)))
        (if result
            (apply values
                   (caar result) (cdar result)
                   (map (lambda (p) (and p (substring str (car p) (cadr p))))
                        (cdr result)))
            (values #f #f #f #f #f #f #f))))))

(define lmtp-from-regex
  (let ((match (regexp "^From (address@hidden) (.+)$")))
    (lambda (str . off)
      (let ((result (apply string-match-positions match str off)))
        (if result
            (apply values
                   (caar result) (cdar result)
                   (map (lambda (p) (and p (substring str (car p) (cadr p))))
                        (cdr result)))
            (values #f #f #f #f))))))

(define lmtp-destination-email-regex
  (let ((match (regexp " *([^[:blank:]]+)[[:blank:]]+<([^>]+)>")))
    (lambda (str . off)
      (let ((result (apply string-match-positions match str off)))
        (if result
            (apply values
                   (caar result) (cdar result)
                   (map (lambda (p) (and p (substring str (car p) (cadr p))))
                        (cdr result)))
            (values #f #f #f #f))))))

(define broken-303-client
  (let ((match (regexp "^Mozilla/4.")))
    (lambda (str) (and (string-match-positions match str) #t))))

(define user-agent-amaya
  (let ((match (regexp "^amaya/")))
    (lambda (str) (and (string-match-positions match str) #t))))

(define user-agent-ie
  (let ((match (regexp "^Microsoft")))
    (lambda (str) (and (string-match-positions match str) #t))))

(define user-agent-mozilla
  (let ((match (regexp "^Mozilla/")))
    (lambda (str) (and (string-match-positions match str) #t))))

;; The additional, optional slash enables forward compatible
;; processing of XPath selections within the target node.
;; TODO add XPath support here.

(define nunu-regexp
  (let ((match (regexp "([[:upper:]][[:alnum:]äÄöÖüÜß]*[[:upper:][:alnum:]äÄöÖüÜß]*)/?")))
    (lambda (str . off)
      (let ((result (apply string-match-positions match str off)))
        (if result
            (values (caar result) (cadar result)
                    (substring str (caar result) (cadar result)))
            (values #f #f #f))))))

(define nunu-include-regexp
  (let ((match (regexp "@([[:upper:]][[:alnum:]äÄöÖüÜß]*[[:upper:][:alnum:]äÄöÖüÜß]*)")))
    (lambda (str . off)
      (let ((result (apply string-match-positions match str off)))
        (if result
            (values (caar result) (cadar result)
                    (substring str (caadr result) (cadadr result)))
            (values #f #f #f))))))

(define bold-regexp
  (let ((match (regexp "\\*([[:alnum:]äÄöÖüÜß]*)\\*")))
    (lambda (str . off)
      (let ((result (apply string-match-positions match str off)))
        (if result
            (values (caar result) (cadar result)
                    (substring str (caadr result) (cadadr result)))
            (values #f #f #f))))))

(define url-pregexp-regexp
  (let ((match (regexp
                (string-append
                 "(((https?|ftp)://[-[:alnum:]\\.]+(:[[:digit:]]+)?[^[:blank:]]*)"
                 "|(mailto:[-[:alnum:address@hidden:alnum:]\\.]+))"
                 ))))
    (lambda (str . off)
      (let ((result (apply string-match-positions match str off)))
        (if result
            (values (caar result) (cadar result)
                    (substring str (caar result) (cadar result)))
            (values #f #f #f))))))

(define nunu-oid-regexp
  (let ((match (regexp "(A[[:xdigit:]]{32}(:/[^[:space:]<]+)?)")))
    (lambda (str . off)
      (let ((result (apply string-match-positions match str off)))
        (if result
            (values (caar result) (cadar result)
                    (substring str (caar result) (cadar result)))
            (values #f #f #f))))))

(define url-regexp url-pregexp-regexp)

(define sql-special-regexp
  (reg-expr->proc "\"|'|"))

(define colon-split-regex
  (regexp "([^:]+):[[:blank:]]+(.*)$"))

;; We could be less restrictive here.  But why should we?
(define illegal-lout?
  (let ((match (regexp
                (string-append "@(Include|SysInclude|IncludeGraphic|PrependGraphic"
                               "|SysPrependGraphic|Database|SysDatabase|Filter)"))))
    (lambda (str) (and (string-match-positions match str) #t))))

(define lout-literal-char-sequence-regexp
  (let ((match (regexp "([^\"&{}|address@hidden ]+)")))
    (lambda (str . off)
      (let ((result (apply string-match-positions match str off)))
        (if result
            (values (caar result) (cdar result)
                    (substring str (caadr result) (cadadr result)))
            (values #f #f #f))))))

(define lout-collapsable-whitespace-sequence-regexp
  (let ((match (regexp "[[:blank:]]+")))
    (lambda (str . off)
      (let ((result (apply string-match-positions match str off)))
        (if result
            (values (caar result) (cadar result)
                    (substring str (caar result) (cadar result)))
            (values #f #f #f))))))

;;** Tables

(define (make-symbol-table) (make-hash-table eq? symbol-hash))

(define (make-fixnum-table) (make-hash-table eqv? equal?-hash))

(define (make-character-table) (make-hash-table eqv? equal?-hash))

(define (make-string-table) (make-hash-table string=? string-hash))

;;** BLOBs

(define *transient-blobs* (make-symbol-table))

(define *transient-blobs-mutex* (make-mutex 'transient-blobs))

(define (register-blob-ref! sha256 obj)
  (with-mutex
   *transient-blobs-mutex*
   (hash-table-update!
    *transient-blobs*
    sha256
    (lambda (old) (list (add1 (car old))))
    (lambda () (list 0)))))

(define (unregister-blob-ref! sha256 obj)
  (with-mutex
   *transient-blobs-mutex*
   (let ((old (hash-table-ref *transient-blobs* sha256
			      (lambda () (error "blobref not registered")))))
     (if (eqv? (car old) 1)
	 (hash-table-delete! *transient-blobs* sha256)
	 (hash-table-set! *transient-blobs* sha256 (list (sub1 (car old))))))))

(define (non-transient-blob? sha256)
  (not (hash-table-ref/default *transient-blobs* sha256 #f)))

;;** future

(define-record-type <future>
  (internal-make-future mutex condition has-result result)
  future?
  (mutex future-mutex)
  (condition future-condition)
  (has-result future-has-result future-has-result-set!)
  (result future-result future-result-set!))

(define (future-force f)
  (if (future-has-result f)
      (future-result f)
      (begin
        (mutex-lock! (future-mutex f))
        (if (future-has-result f)
            (begin
              (mutex-unlock! (future-mutex f))
              (future-result f))
            (begin
              (mutex-unlock! (future-mutex f) (future-condition f))
              (future-result f))))))

(define (thunk->future thunk name)
  (let ((f (internal-make-future (make-mutex)
                                 (make-condition-variable)
                                 #f 'invalid)))
    (thread-start!
     (make-thread
      (lambda ()
        (future-result-set! f (with-exception-guard identity thunk))
        (future-has-result-set! f #t)
        (condition-variable-broadcast! (future-condition f)))
      name))
    (delay (future-force f))))

;;** semaphore

(define-record-type <semaphore>
  (internal-make-semaphore name n mutex condition)
  semaphore?
  (name semaphore-name)
  (n semaphore-value semaphore-value-set!)
  (mutex semaphore-mutex)
  (condition semaphore-condition))

(define (make-semaphore name n)
  (internal-make-semaphore name n (make-mutex) (make-condition-variable)))

(define (semaphore-wait-by! sema decrement)
  (mutex-lock! (semaphore-mutex sema))
  (let ((n (semaphore-value sema)))
    (if (fx>= n decrement)
        (begin
          (semaphore-value-set! sema (- n decrement))
          (mutex-unlock! (semaphore-mutex sema)))
        (begin
          (mutex-unlock! (semaphore-mutex sema) (semaphore-condition sema))
          (semaphore-wait-by! sema decrement)))))

(define (semaphore-signal-by! sema increment)
  (mutex-lock! (semaphore-mutex sema))
  (let ((n (+ (semaphore-value sema) increment)))
    (semaphore-value-set! sema n)
    (if (fx> n 0)
        (condition-variable-broadcast! (semaphore-condition sema)))
    (mutex-unlock! (semaphore-mutex sema))))

(define (mutex-owner mux)
  (let ((s (mutex-state mux)))
    (and (thread? s) s)))

(define-record-type <mailbox>
  (internal-make-mailbox mutex condition queue)
  mailbox?
  (mutex mailbox-mutex)
  (condition mailbox-condition)
  (queue mailbox-queue))

(define (make-mailbox . name)
  (internal-make-mailbox
   (apply make-mutex name) (apply make-condition-variable name) (make-queue)))

(define (mailbox-clone mailbox)
  (let ((name (mutex-name (mailbox-mutex mailbox))))
    (internal-make-mailbox
     (make-mutex name) (make-condition-variable name)
     (list->queue (queue->list (mailbox-queue mailbox))))))

(define (mailbox-has-message? mailbox message equal)
  (find (lambda (x) (equal message x)) (queue->list (mailbox-queue mailbox))))

(define (mailbox-empty? mb)
  (queue-empty? (mailbox-queue mb)))

(define (mailbox-number-of-items mb)
  (length (queue->list (mailbox-queue mb))))

(define (send-message! mailbox obj)
  (mutex-lock! (mailbox-mutex mailbox))
  (queue-add! (mailbox-queue mailbox) obj)
  (condition-variable-signal! (mailbox-condition mailbox))
  (mutex-unlock! (mailbox-mutex mailbox))
  (void))

(define (receive-message! mailbox)
  (mutex-lock! (mailbox-mutex mailbox))
  (if (queue-empty? (mailbox-queue mailbox))
      (begin
        (mutex-unlock! (mailbox-mutex mailbox) (mailbox-condition mailbox))
        (receive-message! mailbox))
      (let ((obj (queue-remove! (mailbox-queue mailbox))))
        (mutex-unlock! (mailbox-mutex mailbox))
        obj)))

(define (receive-message-if-present! mb)
  (if (mailbox-empty? mb) (values #f #f) (values (receive-message! mb) #t)))

(define (mailbox-drop-matching! mailbox pred)
    (let loop ()
      (cond
       ((mailbox-empty? mailbox) #t)
       ((pred (queue-first (mailbox-queue mailbox)))
	(receive-message! mailbox) (loop))
       (else #f))))

(define (call-with-list-extending proc)
  (let ((first #f)
	(last (cons 0 '())))
    (set! first last)
    (let ((result (proc (lambda (item)
			  (let ((cell (cons item '())))
			    (set-cdr! last cell)
			    (set! last cell)
			    item)))))
      (values (cdr first) result))))

(define (call-with-list-extending1 proc)
  (let ((first #f)
	(last (cons 0 '())))
    (set! first last)
    (let ((result (proc (lambda (item)
			  (let ((cell (cons item '())))
			    (set-cdr! last cell)
			    (set! last cell)
			    item)))))
      (cdr first))))

;; include the portable code

(include "../mechanism/util.scm")
;(include "../mechanism/srfi/strings.scm")
;;** String Manipulation

;;
;; There are things, which could be better supported by the scheme
;; standard :-(.  I think the Perl or even TCL way of implicit
;; converting everything hides too much of the relevant complexity
;; from the programer.  But Scheme is way too poor the other way
;; around.

;; The string library is still in draft state.  The following will
;; probably not become SRFI.  It's here because the code already uses
;; them.

(define (string-replw str width)
  (if (string=? str "")
      ""
      (let ((str-len (string-length str)))
	(let loop ((result "") (size 0))
	  (cond ((= size width) result)
		((> size width) (substring result 0 width))
		(else (loop (string-append result str) (+ size str-len))))))))

(define (string-left s1 width . s2)
  (let ((padding (if (pair? s2) (car s2) " "))
	(str-len (string-length s1)))
    (cond ((> width str-len)
	   (string-append s1 (string-replw padding (- width str-len))))
	  ((< width str-len) (substring s1 0 width))
	  (else s1))))

(define (string-right s1 width . s2)
  (let ((padding (if (pair? s2) (car s2) " "))
	(str-len (string-length s1)))
    (cond ((> width str-len)
	   (string-append (string-replw padding (- width str-len)) s1))
	  ((< width str-len) (substring s1 (- str-len  width) str-len))
	  (else s1))))

(define (has-suffix? suffix str)
  (let ((ql (string-length str)) (sl (string-length suffix)))
    (and (>= ql sl) (string=? suffix (substring str (- ql sl) ql)))))

(define (to-string obj) (format "~a" obj))

;; Some Scheme implementations functions have a limited argument
;; count.  We might need to apply string-append to long lists.

(define (apply-string-append lst)
  (define (return-len buffer i str j continue) i)
  (cond
   ((null? lst) "")
   ((null? (cdr lst)) (car lst))
   (else
    (let* ((length (fold (lambda (s i) (fx+ i (string-length s))) 0 lst))
           (result (make-string length)))
      (let loop ((i 0) (from lst))
        (if (eqv? i length)
            result
            (loop (string-splice! result i (car from) 0 return-len)
                  (cdr from))))))))

(define srfi:string-join string-join)

;; search the longest prefix in s1 and s2 terminated by sep 
(define (string-prefix-length+ s1 s2 sep)
  (string-index-right s1 sep 0 (string-prefix-length s1 s2)))