initial import

src/xmpp/core.scm

@@ -0,0 +1 @@
+(define-module (xmpp core))

src/xmpp/core/auth.scm

@@ -0,0 +1,51 @@
+(define-module (xmpp core auth)
+  #:use-module (sxml match)
+
+  #:use-module (xmpp core stanza)
+  #:use-module (xmpp core stream)
+  #:use-module (xmpp core namespaces)
+  #:use-module (xmpp core jid)
+  #:use-module (xmpp core)
+  #:use-module (xmpp utils base64)
+
+  #:export (xmpp-negotiate-sasl-mechanisms))
+
+(define (plain-client-message authcid password)
+  (base64-encode
+   (string-append
+    "\0" authcid
+    "\0" password)))
+
+(define (xmpp-negotiate-sasl-plain xmpp-stream)
+  (let ((data (plain-client-message (jid-local (xmpp-stream-jid xmpp-stream))
+                                    (current-xmpp-client-password))))
+    (xmpp-write-stanza xmpp-stream `(auth (@ (xmlns ,(cdr *sasl-ns*)) (mechanism "PLAIN")) ,data))
+    (let ((plain-response (xmpp-read-stanza xmpp-stream)))
+      (sxml-match
+       plain-response
+       ((*TOP* (sasl:success))
+        (xmpp-negotiate-features (xmpp-restart-stream xmpp-stream)))
+       ((*TOP* (sasl:failure
+                (sasl:not-authorized
+                 (sasl:text (@ (xml:lang ,lang)) ,message))))
+        (begin
+          (xmpp-stream-error-set! xmpp-stream 'not-authorized)
+          xmpp-stream))
+       ((*TOP* (stream:error . ,the-error))
+;                (stream-error:not-well-formed
+;                 (stream-error:text (@ (xml:lang ,lang)) . ,error-text))))
+        (error the-error))
+       (,otherwise
+        (format #t "~a\n" plain-response))))))
+
+(define (xmpp-negotiate-sasl-choose-mechanism xmpp-stream mechanisms)
+  (xmpp-negotiate-sasl-plain xmpp-stream))
+
+(define (xmpp-negotiate-sasl-mechanisms xmpp-stream)
+  (let ((mechanisms-stanza (xmpp-read-stanza xmpp-stream)))
+    (sxml-match
+     mechanisms-stanza
+     ((*TOP* (stream:features (sasl:mechanisms . ,mechanisms)))
+      (xmpp-negotiate-sasl-choose-mechanism xmpp-stream mechanisms))
+     (,otherwise
+      mechanisms-stanza))))

src/xmpp/core/handlers.scm

@@ -0,0 +1,45 @@
+(define-module (xmpp core handlers)
+  #:use-module (ice-9 optargs)
+  #:use-module (fibers)
+
+  #:use-module (xmpp core stream)
+
+  #:export (xmpp-stream-handler-initialize!
+            xmpp-stream-handler-stop!
+            xmpp-stream-handler-set-callback!
+            xmpp-stream-handler-unset-callback!
+            xmpp-stream-handler-callbacks))
+
+(define-record-type <xmpp-stream-handler>
+  (make-xmpp-stream handler thread callbacks)
+  xmpp-stream-handler
+  (handler xmpp-stream-handler-handler xmpp-stream-handler-handler-set!)
+  (thread xmpp-stream-handler-thread xmpp-stream-handler-thread-set!)
+  (callbacks xmpp-stream-handler-callbacks xmpp-stream-handler-callbacks-set!))
+
+(define (default-xmpp-handler xmpp-stream stanza)
+  #t)
+
+(define-values
+    (xmpp-stream-handler-initialize!
+     xmpp-stream-handler-stop!
+     xmpp-stream-handler-set-callback!
+     xmpp-stream-handler-unset-callback!
+     xmpp-stream-handler-callbacks)
+  (let ((handler-hash (make-hash-table)))
+    (values
+     ;; initialize!
+     (lambda* (xmpp-stream #:optional (handler default-xmpp-handler))
+       #t)
+     ;; stop!
+     (λ (xmpp-stream)
+       #t)
+     ;; set-callback!
+     (λ (xmpp-stream callback)
+       #t)
+     ;; unset-callback!
+     (λ (xmpp-stream callback)
+       #t)
+     ;; callbacks
+     (λ (xmpp-stream)
+       (xmpp-stream-handler-callbacks (xmpp-stream-handler-handler xmpp-stream)))))

src/xmpp/core/jid.scm

@@ -0,0 +1,127 @@
+(define-module (xmpp core jid)
+  #:use-module (ice-9 regex)
+  #:use-module (ice-9 optargs)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-13)
+  #:use-module (srfi srfi-14)
+  #:export (jid?
+            jid-local jid-host jid-resource set-jid-resource!
+            jid->string
+            build-jid string->jid jid-or-string->jid))
+
+(define-record-type <jid>
+  (make-jid local host resource)
+  jid?
+  (local jid-local)
+  (host jid-host)
+  (resource jid-resource set-jid-resource!))
+
+;; host validation code stolen from guile's web/uri module
+(define (jid-error message . args)
+  (throw 'jid-error message args))
+
+(define host-regex
+  (make-regexp "^([a-z0-9][a-z0-9-]*[a-z0-9][.])+[a-z0-9][a-z0-9-]*[a-z0-9]$" regexp/icase))
+(define ipv4-regexp
+  (make-regexp "^([0-9.]+)$"))
+(define ipv6-regexp
+  (make-regexp "^([0-9a-fA-F:.]+)$"))
+(define host-label-regexp
+  (make-regexp "^[a-zA-Z0-9]([a-zA-Z0-9-]*[a-zA-Z0-9])?$"))
+(define top-label-regexp
+  (make-regexp "^[a-zA-Z]([a-zA-Z0-9-]*[a-zA-Z0-9])?$"))
+
+(define (valid-host? host)
+  (cond
+   ((regexp-exec ipv4-regexp host)
+    (false-if-exception (inet-pton AF_INET host)))
+   ((regexp-exec ipv6-regexp host)
+    (false-if-exception (inet-pton AF_INET6 host)))
+   (else
+    (let lp ((start 0))
+      (let ((end (string-index host #\. start)))
+        (if end
+            (and (regexp-exec host-label-regexp
+                              (substring host start end))
+                 (lp (1+ end)))
+            (regexp-exec top-label-regexp host start)))))))
+
+
+(define (valid-local? local)
+  (not (string-any
+        (λ (c)
+          (or (char<=? c #\x20)
+              (char=? c #\x22)
+              (char=? c #\x26)
+              (char=? c #\x27)
+              (char=? c #\x2F)
+              (char=? c #\x3A)
+              (char=? c #\x3C)
+              (char=? c #\x3E)
+              (char=? c #\x40)
+              (char=? c #\x7F)
+              (char=? c #\xFFFF)
+              (char=? c #\xFFFE)))
+        local)))
+
+(define (valid-resource? resource)
+  (not (string-any (λ (s)
+                     (or (char-ci<? s #\x20)
+                         (char-ci=? s #\xFFFF)
+                         (char-ci=? s #\xFFFE)))
+                   resource)))
+
+(define* (build-jid host #:optional (local #f) (resource #f))
+  (cond
+   ((not (string? host))
+    (jid-error "Expected string for host: ~s" host))
+
+   ((and local (or (not (string? local)) (not (valid-local? local))))
+    (jid-error "Invalid local part: ~s" local))
+
+   ((not (valid-host? host))
+    (jid-error "Invalid host: ~s" host))
+
+   ((and resource (or (not (string? resource)) (not (valid-resource? resource))))
+    (jid-error "Invalid resource: ~s" resource)))
+  (make-jid local host resource))
+
+(define (bare-jid-from-string str)
+  (if (string? str)
+      (car (string-split str #\/))
+      (jid-error "Expected a string: ~s" str)))
+
+(define (local-from-string str)
+  (let ((bare (bare-jid-from-string str)))
+    (if (string-contains bare "@")
+        (car (string-split bare #\@))
+        #f)))
+
+(define (host-from-string str)
+  (let ((bare (bare-jid-from-string str)))
+    (if (string-contains bare "@")
+        (cadr (string-split bare #\@))
+        bare)))
+
+(define (resource-from-string str)
+  (if (string? str)
+      (let ((parts (string-split str #\/)))
+        (if (>= (length parts) 2)
+            (cadr parts)
+            #f))
+      (jid-error "Expected string: ~s" str)))
+
+(define (jid-or-string->jid jid-or-string)
+  (cond ((jid? jid-or-string)
+         jid-or-string)
+        ((string? jid-or-string)
+         (string->jid jid-or-string))
+        (else (jid-error "Argument must be a jid or a string.  Given: " jid-or-string))))
+
+(define (string->jid str)
+  (build-jid (host-from-string str) (local-from-string str) (resource-from-string str)))
+
+(define (jid->string jid)
+  (if (jid-resource jid)
+      (string-append (jid-local jid) "@" (jid-host jid) "/" (jid-resource jid))
+      (string-append (jid-local jid) "@" (jid-host jid))))

src/xmpp/core/namespaces.scm

@@ -0,0 +1,44 @@
+(define-module (xmpp core namespaces))
+
+(define-public *stream-ns* '(stream . "http://etherx.jabber.org/streams"))
+(define-public *tls-ns* '(tls . "urn:ietf:params:xml:ns:xmpp-tls"))
+(define-public *sasl-ns* '(sasl . "urn:ietf:params:xml:ns:xmpp-sasl"))
+(define-public *compression-ns* '(compression . "http://jabber.org/features/compress"))
+(define-public *bind-ns* '(bind . "urn:ietf:params:xml:ns:xmpp-bind"))
+(define-public *amp-ns* '(amp . "http://jabber.org/features/amp"))
+(define-public *bidi-ns* '(bidi . "urn:xmpp:bidi"))
+(define-public *server-dialback-ns* '(dialback . "urn:xmpp:features:dialback"))
+(define-public *iq-auth-ns* '(iq-quth . "http://jabber.org/features/iq-auth"))
+(define-public *iq-register-ns* '(iq-register . "http://jabber.org/features/iq-register"))
+(define-public *session-ns* '(session . "urn:ietf:params:xml:ns:xmpp-session"))
+(define-public *sm3-ns* '(sm3 . "urn:xmpp:sm:3"))
+(define-public *sm2-ns* '(sm2 . "urn:xmpp:sm:2"))
+(define-public *caps-ns* '(caps . "http://jabber.org/protocol/caps"))
+(define-public *ver-ns* '(ver . "urn:xmpp:features:rosterver"))
+(define-public *csi-ns* '(csi . "urn:xmpp:csi:0"))
+(define-public *client-ns* '(client . "jabber:client"))
+(define-public *server-ns* '(server . "jabber:server"))
+(define-public *stream-error-ns* '(stream-error . "urn:ietf:params:xml:ns:xmpp-streams"))
+(define-public *stanza-error-ns* '(stanza-error . "urn:ietf:params:xml:ns:xmpp-stanza"))
+
+(define-public %default-namespaces
+  (list *stream-ns*
+        *tls-ns*
+        *sasl-ns*
+        *compression-ns*
+        *bind-ns*
+        *amp-ns*
+        *bidi-ns*
+        *server-dialback-ns*
+        *iq-auth-ns*
+        *iq-register-ns*
+        *session-ns*
+        *sm3-ns*
+        *sm2-ns*
+        *caps-ns*
+        *ver-ns*
+        *csi-ns*
+        *client-ns*
+        *server-ns*
+        *stream-error-ns*
+        *stanza-error-ns*))

src/xmpp/core/stanza.scm

@@ -0,0 +1,56 @@
+(define-module (xmpp core stanza)
+  #:use-module (sxml match)
+  #:use-module (sxml ssax)
+  #:use-module (sxml ssax input-parse)
+  #:use-module (sxml simple)
+
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 regex)
+  #:use-module (ice-9 format)
+  #:use-module (rnrs io ports)
+
+  #:use-module (xmpp core namespaces)
+  #:use-module (xmpp core stream)
+  #:use-module (xmpp core jid)
+
+  #:export (xmpp-write-stream-header
+            xmpp-read-stream-header
+            xmpp-read-stanza
+            xmpp-write-stanza))
+
+(define* (xmpp-write-stream-header port host #:optional (from #f))
+  (format
+   port
+   "<?xml version=\"1.0\"?><~a:stream version=\"1.0\" from=\"~a\" to=\"~a\" xml:lang=\"en\" xmlns:~a=\"~a\" xmlns=\"jabber:client\">"
+   (symbol->string (car *stream-ns*))
+   (jid->string from)
+   host
+   (symbol->string (car *stream-ns*))
+   (cdr *stream-ns*))
+  (force-output port))
+
+(define (xmpp-read-stream-header socket-port)
+  (let* ((pi (read-delimited ">" socket-port 'concat))
+         (stream (regexp-substitute #f (string-match ">$" (read-delimited ">" socket-port 'concat)) 'pre "/>"))
+         (xml (string-join (list pi stream) ""))
+         (header-stanza (xml->sxml xml #:trim-whitespace? #t #:namespaces (list *stream-ns*))))
+    (sxml-match header-stanza
+                ((*TOP*
+                  (*PI* . ,pi)
+                  (stream:stream
+                   (@ (id ,stream-id) (version ,stream-version) (xml:lang ,lang) (from ,from) (to ,to) . ,attribs) . ,stream))
+                 (values stream-id from (string->jid to) stream-version lang))
+                (,otherwise
+                 (error header-stanza)))))
+
+  (define (xmpp-read-stanza xmpp-stream)
+    (let ((port (xmpp-stream-get-port xmpp-stream)))
+      (if (eof-object? (peek-char port))
+          eof-object
+          (xml->sxml port #:trim-whitespace? #t #:namespaces (xmpp-stream-namespaces xmpp-stream)))))
+
+  (define (xmpp-write-stanza xmpp-stream stanza)
+    (let ((port (xmpp-stream-get-port xmpp-stream)))
+      (sxml->xml stanza port)
+      (force-output port)))

src/xmpp/core/stream.scm

@@ -0,0 +1,169 @@
+(define-module (xmpp core stream)
+  #:use-module (fibers)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+
+  #:use-module (rnrs bytevectors)
+  #:use-module (rnrs io ports)
+
+  #:use-module (ice-9 receive)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 regex)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 suspendable-ports)
+
+  #:use-module (gnutls)
+
+  #:use-module (sxml match)
+  #:use-module (sxml simple)
+
+  #:use-module (xmpp core jid)
+  #:use-module (xmpp core auth)
+  #:use-module (xmpp core stanza)
+  #:use-module (xmpp core namespaces)
+
+  #:export (make-xmpp-stream
+            xmpp-close-stream
+            xmpp-stream-get-port
+            xmpp-stream-error-set!
+            xmpp-stream-jid
+            current-xmpp-client-password
+            xmpp-restart-stream
+            xmpp-stream-namespaces
+            xmpp-negotiate-features))
+
+(define current-xmpp-stream (make-parameter #f))
+(define current-xmpp-client-jid (make-parameter #f (λ (val) (if (or (eq? #f val) (jid? val)) val (error "must be a jid")))))
+(define current-xmpp-client-password (make-parameter #f))
+(define %default-xmpp-port* 5222)
+(define %disconnect-timeout* 2000)
+(define %connect-timeout* 5000)
+
+(define *stream-version* "1.0")
+(define *stream-lang* "en")
+
+(define-record-type <xmpp-stream>
+  (make-xmpp-stream host jid stream-loop namespaces handler callbacks tls-session port id version lang features error connected? encrypted?)
+  xmpp-stream?
+  (host xmpp-stream-host xmpp-stream-host-set!)
+  (tls-session xmpp-stream-tls-session xmpp-stream-tls-session-set!)
+  (jid xmpp-stream-jid xmpp-stream-jid-set!)
+  (password xmpp-stream-password xmpp-stream-password-set!)
+  (stream-loop xmpp-stream-stream-loop xmpp-stream-stream-loop-set!)
+  (namespaces xmpp-stream-namespaces xmpp-stream-namespaces-set!)
+  (handler xmpp-stream-handler)
+  (callbacks xmpp-stream-callbacks xmpp-stream-callbacks-set!)
+  (port xmpp-stream-port xmpp-stream-port-set!)
+  (id stream-id xmpp-stream-id-set!)
+  (version xmpp-stream-version xmpp-stream-version-set!)
+  (lang stream-lang)
+  (features xmpp-stream-features xmpp-stream-features-set!)
+  (error xmpp-stream-error xmpp-stream-error-set!)
+  (connected? xmpp-stream-connected? xmpp-stream-connected?-set!)
+  (encrypted? xmpp-stream-encrypted? xmpp-stream-encrypted?-set!))
+
+(define (xmpp-restart-stream xmpp-stream)
+  (let ((port (xmpp-stream-get-port xmpp-stream)))
+    (xmpp-write-stream-header
+     port
+     (xmpp-stream-host xmpp-stream)
+     (if (xmpp-stream-jid xmpp-stream) (xmpp-stream-jid xmpp-stream) #f))
+    (receive (id from jid version lang)
+        (xmpp-read-stream-header port)
+      (xmpp-stream-version-set! xmpp-stream version)
+      (xmpp-stream-id-set! xmpp-stream id)
+      xmpp-stream)))
+
+(define (xmpp-restart-stream-tls xmpp-stream)
+  (let ((session (make-session connection-end/client))
+        (credentials (make-certificate-credentials)))
+    (set-session-default-priority! session)
+    (set-session-server-name! session server-name-type/dns (xmpp-stream-host xmpp-stream))
+    (set-session-credentials! session credentials)
+    (set-session-priorities! session "NORMAL:%COMPAT:-VERS-SSL3.0")
+    (set-session-dh-prime-bits! session 2048)
+    (set-session-transport-fd! session (fileno (xmpp-stream-port xmpp-stream)))
+
+    ;; set nonblocking
+    (setvbuf (xmpp-stream-port xmpp-stream) 'block 1024)
+    (setsockopt client OPPROTO_TCP TCP_NODELAY 1)
+    (handshake session)
+
+    (catch 'gnutls-error
+      (λ ()
+        (let ((port (session-record-port session)))
+          (xmpp-write-stream-header port (xmpp-stream-host xmpp-stream) (xmpp-stream-jid xmpp-stream))
+          (receive (id from jid version lang)
+              (xmpp-read-stream-header port)
+            (make-xmpp-stream from jid #f %default-namespaces '() session #f id version lang '() #f #t #t))))
+      (λ (key error function)
+        (close-port (xmpp-stream-port xmpp-stream))
+        (scm-error 'xmpp-stream "negotiate-tls" "handshake error" function #f)))))
+
+;;; if the stream is encrypted the port is encapsulated in a tls session
+;;; instead of a plain port
+(define (xmpp-stream-get-port xmpp-stream)
+  (if (xmpp-stream-encrypted? xmpp-stream)
+      (session-record-port (xmpp-stream-tls-session xmpp-stream))
+      (xmpp-stream-port xmpp-stream)))
+
+(define* (xmpp-open-client-stream jid #:optional (host #f) (s2s? #f))
+  (let* ((host (if host host (jid-host jid)))
+         (service (if s2s? "xmpp-server" "xmpp-client"))
+         (addresses (delete-duplicates (getaddrinfo host service)
+                                       (λ (a1 a2)
+                                         (equal? (addrinfo:addr a1)
+                                                 (addrinfo:addr a2))))))
+    (let try-connect ((addresses addresses))
+      (let* ((ai (car addresses))
+             (socket-port (with-fluids ((%default-port-encoding #f))
+                            (socket (addrinfo:fam ai)
+                                    (addrinfo:socktype ai)
+                                    (addrinfo:protocol ai)))))
+        (catch 'system-error
+          (λ ()
+            (connect socket-port (addrinfo:addr ai))
+            (xmpp-write-stream-header socket-port host jid)
+            (receive (id from jid version lang)
+                (xmpp-read-stream-header socket-port)
+              (make-xmpp-stream from jid #f %default-namespaces '() #f socket-port id version lang '() #f #t #f)))
+          (λ args
+            (close socket-port)
+            (if (null? (cdr addresses))
+                (apply throw args)
+                (try-connect (cdr addresses)))))))))
+
+(define (xmpp-negotiate-tls-starttls xmpp-stream)
+  (xmpp-write-stanza xmpp-stream `(starttls (@ (xmlns ,(cdr *tls-ns*))))))
+
+(define (xmpp-close-stream xmpp-stream)
+  (format (xmpp-stream-get-port xmpp-stream) "</stream:stream>")
+  (force-output (xmpp-stream-get-port xmpp-stream)))
+
+
+(define (xmpp-negotiate-tls xmpp-stream)
+  (xmpp-negotiate-tls-starttls xmpp-stream)
+  (let ((starttls-stanza (xmpp-read-stanza xmpp-stream)))
+    (sxml-match
+     starttls-stanza
+     ((*TOP* (tls:proceed))
+      (xmpp-negotiate-sasl-mechanisms (xmpp-restart-stream-tls xmpp-stream)))
+     (,otherwise starttls-stanza))))
+
+(define (xmpp-negotiate-features xmpp-stream)
+  (let ((features-stanza (xmpp-read-stanza xmpp-stream)))
+    (sxml-match
+     features-stanza
+     ((*TOP* (stream:features (tls:starttls (tls:required))))
+      (xmpp-negotiate-tls xmpp-stream))
+     ((*TOP* (stream:features . ,features))
+      (xmpp-stream-features-set! xmpp-stream features)
+      xmpp-stream)
+     (,otherwise
+      features-stanza))))
+
+(define* (xmpp-stream-connect-client jid password #:optional (host #f))
+  (parameterize ((current-xmpp-client-jid jid) (current-xmpp-client-password password))
+    (let ((xmpp-stream (xmpp-open-client-stream jid host)))
+      (xmpp-negotiate-features xmpp-stream))))

src/xmpp/utils/base64.scm

@@ -0,0 +1,225 @@
+;;  -*-  indent-tabs-mode:nil; coding: utf-8 -*-
+
+;; Copyright © 2009, 2010, 2012, 2013 Göran Weinholt <goran@weinholt.se>
+;; Copyright 2018 Mu Lei known as NalaGinrut <nalaginrut@gmail.com>
+
+;; Permission is hereby granted, free of charge, to any person obtaining a
+;; copy of this software and associated documentation files (the "Software"),
+;; to deal in the Software without restriction, including without limitation
+;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
+;; and/or sell copies of the Software, and to permit persons to whom the
+;; Software is furnished to do so, subject to the following conditions:
+
+;; The above copyright notice and this permission notice shall be included in
+;; all copies or substantial portions of the Software.
+
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
+;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;; DEALINGS IN THE SOFTWARE.
+
+;; RFC 4648 Base-N Encodings
+
+(define-module (xmpp utils base64)
+  #:use-module ((rnrs) :version (6))
+  #:export (base64-encode base64-decode))
+
+(define base64-alphabet
+  "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
+
+(define base64url-alphabet
+  "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_")
+
+(define %base64-encode
+  (case-lambda
+    ;; Simple interface. Returns a string containing the canonical
+    ;; base64 representation of the given bytevector.
+    ((bv)
+     (%base64-encode bv 0 (bytevector-length bv) #f #f base64-alphabet #f))
+    ((bv start)
+     (%base64-encode bv start (bytevector-length bv) #f #f base64-alphabet #f))
+    ((bv start end)
+     (%base64-encode bv start end #f #f base64-alphabet #f))
+    ((bv start end line-length)
+     (%base64-encode bv start end line-length #f base64-alphabet #f))
+    ((bv start end line-length no-padding)
+     (%base64-encode bv start end line-length no-padding base64-alphabet #f))
+    ((bv start end line-length no-padding alphabet)
+     (%base64-encode bv start end line-length no-padding alphabet #f))
+    ;; Base64 encodes the bytes [start,end[ in the given bytevector.
+    ;; Lines are limited to line-length characters (unless #f),
+    ;; which must be a multiple of four. To omit the padding
+    ;; characters (#\=) set no-padding to a true value. If port is
+    ;; #f, returns a string.
+    ((bv start end line-length no-padding alphabet port)
+     (assert (or (not line-length) (zero? (mod line-length 4))))
+     (let-values (((p extract) (if port
+                                   (values port (lambda () (values)))
+                                   (open-string-output-port))))
+       (letrec ((put (if line-length
+                         (let ((chars 0))
+                           (lambda (p c)
+                             (when (fx=? chars line-length)
+                               (set! chars 0)
+                               (put-char p #\linefeed))
+                             (set! chars (fx+ chars 1))
+                             (put-char p c)))
+                         put-char)))
+         (let lp ((i start))
+           (cond ((= i end))
+                 ((<= (+ i 3) end)
+                  (let ((x (bytevector-uint-ref bv i (endianness big) 3)))
+                    (put p (string-ref alphabet (fxbit-field x 18 24)))
+                    (put p (string-ref alphabet (fxbit-field x 12 18)))
+                    (put p (string-ref alphabet (fxbit-field x 6 12)))
+                    (put p (string-ref alphabet (fxbit-field x 0 6)))
+                    (lp (+ i 3))))
+                 ((<= (+ i 2) end)
+                  (let ((x (fxarithmetic-shift-left (bytevector-u16-ref bv i (endianness big)) 8)))
+                    (put p (string-ref alphabet (fxbit-field x 18 24)))
+                    (put p (string-ref alphabet (fxbit-field x 12 18)))
+                    (put p (string-ref alphabet (fxbit-field x 6 12)))
+                    (unless no-padding
+                      (put p #\=))))
+                 (else
+                  (let ((x (fxarithmetic-shift-left (bytevector-u8-ref bv i) 16)))
+                    (put p (string-ref alphabet (fxbit-field x 18 24)))
+                    (put p (string-ref alphabet (fxbit-field x 12 18)))
+                    (unless no-padding
+                      (put p #\=)
+                      (put p #\=)))))))
+       (extract)))))
+
+;; Create a lookup table for the alphabet and remember the latest table.
+(define get-decode-table
+  (let ((ascii-table #f)
+        (extra-table '())     ;in the unlikely case of unicode chars
+        (table-alphabet #f))
+    (lambda (alphabet)
+      (unless (eq? alphabet table-alphabet)
+        ;; Rebuild the table.
+        (do ((ascii (make-vector 128 #f))
+             (extra '())
+             (i 0 (+ i 1)))
+            ((= i (string-length alphabet))
+             (set! ascii-table ascii)
+             (set! extra-table extra))
+          (let ((c (char->integer (string-ref alphabet i))))
+            (if (fx<=? c 127)
+                (vector-set! ascii c i)
+                (set! extra (cons (cons c i) extra)))))
+        (set! table-alphabet alphabet))
+      (values ascii-table extra-table))))
+
+;; Decodes a correctly padded base64 string, optionally ignoring
+;; non-alphabet characters.
+(define %base64-decode
+  (case-lambda
+    ((str)
+     (%base64-decode str base64-alphabet #f))
+    ((str alphabet)
+     (%base64-decode str alphabet #f))
+    ((str alphabet port)
+     (%base64-decode str alphabet port #t))
+    ((str alphabet port strict?)
+     (define (pad? c) (eqv? c (char->integer #\=)))
+     (let-values (((p extract) (if port
+                                   (values port (lambda () (values)))
+                                   (open-bytevector-output-port)))
+                  ((ascii extra) (get-decode-table alphabet)))
+       (define-syntax lookup
+         (syntax-rules ()
+           ((_ c) (or (and (fx<=? c 127) (vector-ref ascii c))
+                      (cond ((assv c extra) => cdr)
+                            (else #f))))))
+       (let* ((len (if strict?
+                       (string-length str)
+                       (let lp ((i (fx- (string-length str) 1)))
+                         ;; Skip trailing invalid chars.
+                         (cond ((fxzero? i) 0)
+                               ((let ((c (char->integer (string-ref str i))))
+                                  (or (lookup c) (pad? c)))
+                                (fx+ i 1))
+                               (else (lp (fx- i 1))))))))
+         (let lp ((i 0))
+           (cond
+            ((fx=? i len)
+             (extract))
+            ((fx<=? i (fx- len 4))
+             (let lp* ((c1 (char->integer (string-ref str i)))
+                       (c2 (char->integer (string-ref str (fx+ i 1))))
+                       (c3 (char->integer (string-ref str (fx+ i 2))))
+                       (c4 (char->integer (string-ref str (fx+ i 3))))
+                       (i i))
+               (let ((i1 (lookup c1)) (i2 (lookup c2))
+                     (i3 (lookup c3)) (i4 (lookup c4)))
+                 (cond
+                  ((and i1 i2 i3 i4)
+                   ;; All characters present and accounted for.
+                   ;; The most common case.
+                   (let ((x (fxior (fxarithmetic-shift-left i1 18)
+                                   (fxarithmetic-shift-left i2 12)
+                                   (fxarithmetic-shift-left i3 6)
+                                   i4)))
+                     (put-u8 p (fxbit-field x 16 24))
+                     (put-u8 p (fxbit-field x 8 16))
+                     (put-u8 p (fxbit-field x 0 8))
+                     (lp (fx+ i 4))))
+                  ((and i1 i2 i3 (pad? c4) (= i (- len 4)))
+                   ;; One padding character at the end of the input.
+                   (let ((x (fxior (fxarithmetic-shift-left i1 18)
+                                   (fxarithmetic-shift-left i2 12)
+                                   (fxarithmetic-shift-left i3 6))))
+                     (put-u8 p (fxbit-field x 16 24))
+                     (put-u8 p (fxbit-field x 8 16))
+                     (lp (fx+ i 4))))
+                  ((and i1 i2 (pad? c3) (pad? c4) (= i (- len 4)))
+                   ;; Two padding characters.
+                   (let ((x (fxior (fxarithmetic-shift-left i1 18)
+                                   (fxarithmetic-shift-left i2 12))))
+                     (put-u8 p (fxbit-field x 16 24))
+                     (lp (fx+ i 4))))
+                  ((not strict?)
+                   ;; Non-alphabet characters.
+                   (let lp ((i i) (c* '()) (n 4))
+                     (cond ((fxzero? n)
+                            ;; Found four valid characters.
+                            (lp* (cadddr c*) (caddr c*) (cadr c*) (car c*)
+                                 (fx- i 4)))
+                           ((fx=? i len)
+                            (error '%base64-decode
+                                   "Invalid input in non-strict mode."
+                                   i c*))
+                           (else
+                            ;; Gather alphabetic (or valid
+                            ;; padding) characters.
+                            (let ((c (char->integer (string-ref str i))))
+                              (cond ((or (lookup c)
+                                         (and (pad? c)
+                                              (fx<=? n 2)
+                                              (fx=? i (fx- len n))))
+                                     (lp (fx+ i 1) (cons c c*) (fx- n 1)))
+                                    (else
+                                     (lp (fx+ i 1) c* n))))))))
+                  (else
+                   (error '%base64-decode
+                          "Invalid input in strict mode."
+                          c1 c2 c3 c4))))))
+            (else
+             (error '%base64-decode
+                    "The input is too short, it may be missing padding."
+                    i)))))))))
+
+(define (get-line-comp f port)
+  (if (port-eof? port)
+      (eof-object)
+      (f (get-line port))))
+
+(define (base64-encode str/bv)
+  (%base64-encode (if (string? str/bv) (string->utf8 str/bv) str/bv)))
+
+(define (base64-decode str/bv)
+  (%base64-decode (if (string? str/bv) (string->utf8 str/bv) str/bv)))