about summary refs log tree commit diff
path: root/lisp
diff options
context:
space:
mode:
Diffstat (limited to 'lisp')
-rw-r--r--lisp/dns/README.md75
-rw-r--r--lisp/dns/client.lisp85
-rw-r--r--lisp/dns/default.nix21
-rw-r--r--lisp/dns/message.lisp407
-rw-r--r--lisp/dns/package.lisp11
-rw-r--r--lisp/klatre/OWNERS3
-rw-r--r--lisp/klatre/default.nix14
-rw-r--r--lisp/klatre/klatre.lisp119
-rw-r--r--lisp/klatre/package.lisp16
9 files changed, 751 insertions, 0 deletions
diff --git a/lisp/dns/README.md b/lisp/dns/README.md
new file mode 100644
index 000000000000..c95d2e9a687e
--- /dev/null
+++ b/lisp/dns/README.md
@@ -0,0 +1,75 @@
+dns
+===
+
+This library is a DNS-over-HTTPS client for Common Lisp.
+
+The ambition is to transform it into a fully-featured DNS resolver
+instead of piggy-backing on the HTTPS implementation, but ...
+baby-steps!
+
+Note that there is no Common Lisp HTTP client that fully supports the
+HTTP2 protocol at the moment, so you can not expect this library to
+provide equivalent performance to a native DNS resolver (yet).
+
+## API
+
+The API is kept as simple as it can be.
+
+### Types
+
+The types of this library are implemented as several structs that
+support binary (de-)serialisation via [lisp-binary][].
+
+The existing structs are as follows and directly implement the
+corresponding definitions from [RFC 1035][]:
+
+* `dns-header`
+* `dns-question`
+* `dns-rr`
+* `dns-message`
+
+All relevant field accessors for these structs are exported and can be
+used to inspect query results.
+
+### Functions
+
+All lookup functions are of the type `(function (string &key doh-url)
+(dns-message))` and signal a `dns:doh-error` condition for
+unsuccessful requests.
+
+If `:doh-url` is unspecified, Google's public DNS-over-HTTPS servers
+at [dns.google][https://dns.google] will be used.
+
+Currently implemented lookup functions:
+
+* `lookup-a`
+* `lookup-mx`
+* `lookup-txt`
+
+## Example usage
+
+```lisp
+DNS> (dns-message-answer (lookup-a "git.tazj.in."))
+#(#S(DNS-RR
+     :NAME #S(QNAME :START-AT 29 :NAMES #(12))
+     :TYPE A
+     :CLASS 1
+     :TTL 286
+     :RDLENGTH 4
+     :RDATA #(34 98 120 189)))
+```
+
+## TODO
+
+Various things in this library are currently broken because I only
+implemented it to work for my blog setup, but these things will be
+ironed out.
+
+Most importantly, the following needs to be fixed:
+
+* Each qname *fragment* needs to track its offset, not each qname.
+* The RDATA for a TXT record can have multiple counted strings.
+* qnames should be canonicalised after parsing.
+
+[lisp-binary]: https://github.com/j3pic/lisp-binary
+[RFC 1035]: https://tools.ietf.org/html/rfc1035
diff --git a/lisp/dns/client.lisp b/lisp/dns/client.lisp
new file mode 100644
index 000000000000..cee7bceb54a0
--- /dev/null
+++ b/lisp/dns/client.lisp
@@ -0,0 +1,85 @@
+;; Implementation of a DoH-client, see RFC 8484 (DNS Queries over
+;; HTTPS (DoH))
+
+(in-package #:dns)
+
+(defvar *doh-base-url* "https://dns.google/resolve"
+  "Base URL of the service providing DNS-over-HTTP(S). Defaults to the
+  Google-hosted API.")
+
+(define-condition doh-error (error)
+  ((query-name :initarg :query-name
+               :reader doh-error-query-name
+               :type string)
+   (query-type :initarg :query-type
+               :reader doh-error-query-type
+               :type string)
+   (doh-url :initarg :doh-url
+            :reader doh-error-doh-url
+            :type string)
+   (status-code :initarg :status-code
+                :reader doh-error-status-code
+                :type integer)
+   (response-body :initarg :response-body
+                  :reader doh-error-response-body
+                  :type (or nil (vector (unsigned-byte 8)) string)))
+
+  (:report (lambda (condition stream)
+             (let ((url (doh-error-doh-url condition))
+                   (status (doh-error-status-code condition))
+                   (body (doh-error-response-body condition)))
+               (format stream "DoH service at '~A' responded with non-success (~A): ~%~%~A"
+                       url status body)))))
+
+(defun lookup-generic (name type doh-url)
+  (multiple-value-bind (body status)
+      (drakma:http-request doh-url
+                           :decode-content t
+                           ;; TODO(tazjin): Figure out why 'want-stream' doesn't work
+                           :parameters `(("type" . ,type)
+                                         ("name" . ,name)
+                                         ("ct" . "application/dns-message")))
+    (if (= 200 status)
+        (dns-message-answer
+         (read-binary 'dns-message (flexi-streams:make-in-memory-input-stream body)))
+
+        (restart-case (error 'doh-error
+                             :query-name name
+                             :query-type type
+                             :doh-url doh-url
+                             :status-code status
+                             :response-body body)
+          (call-with-other-name (new-name)
+            :interactive (lambda () (list (the string (read))))
+            :test (lambda (c) (typep c 'doh-error))
+            (lookup-generic new-name type doh-url))
+
+          (call-with-other-type (new-type)
+            :interactive (lambda () (list (the string (read))))
+            :test (lambda (c) (typep c 'doh-error))
+            (lookup-generic name new-type doh-url))
+
+          (call-with-other-url (new-url)
+            :interactive (lambda () (list (the string (read))))
+            :test (lambda (c) (typep c 'doh-error))
+            (lookup-generic name type new-url))))))
+
+(defun lookup-a (name &key (doh-url *doh-base-url*))
+  "Look up the A records at NAME."
+  (lookup-generic name "A" doh-url))
+
+(defun lookup-txt (name &key (doh-url *doh-base-url*))
+  "Look up the TXT records at NAME."
+  (lookup-generic name "TXT" doh-url))
+
+(defun lookup-mx (name &key (doh-url *doh-base-url*))
+  "Look up the MX records at NAME."
+  (lookup-generic name "MX" doh-url))
+
+(defun lookup-cname (name &key (doh-url *doh-base-url*))
+  "Look up the CNAME records at NAME."
+  (lookup-generic name "CNAME" doh-url))
+
+(defun lookup-ns (name &key (doh-url *doh-base-url*))
+  "Look up the NS records at NAME."
+  (lookup-generic name "NS" doh-url))
diff --git a/lisp/dns/default.nix b/lisp/dns/default.nix
new file mode 100644
index 000000000000..cb2445b460c9
--- /dev/null
+++ b/lisp/dns/default.nix
@@ -0,0 +1,21 @@
+{ depot, ... }:
+
+depot.nix.buildLisp.library {
+  name = "dns";
+
+  deps = with depot.third_party.lisp; [
+    drakma
+    lisp-binary
+    iterate
+  ];
+
+  srcs = [
+    ./package.lisp
+    ./message.lisp
+    ./client.lisp
+  ];
+
+  brokenOn = [
+    "ecl" # dynamic cffi
+  ];
+}
diff --git a/lisp/dns/message.lisp b/lisp/dns/message.lisp
new file mode 100644
index 000000000000..46243ac8d3f0
--- /dev/null
+++ b/lisp/dns/message.lisp
@@ -0,0 +1,407 @@
+(in-package :dns)
+
+;; 3.3. Standard RRs
+
+;; The following RR definitions are expected to occur, at least
+;; potentially, in all classes.  In particular, NS, SOA, CNAME, and PTR
+;; will be used in all classes, and have the same format in all classes.
+;; Because their RDATA format is known, all domain names in the RDATA
+;; section of these RRs may be compressed.
+
+;; <domain-name> is a domain name represented as a series of labels, and
+;; terminated by a label with zero length.  <character-string> is a single
+;; length octet followed by that number of characters.  <character-string>
+;; is treated as binary information, and can be up to 256 characters in
+;; length (including the length octet).
+
+
+;; 3.3.11. NS RDATA format
+
+;;     +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
+;;     /                   NSDNAME                     /
+;;     /                                               /
+;;     +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
+
+;; where:
+
+;; NSDNAME         A <domain-name> which specifies a host which should be
+;;                 authoritative for the specified class and domain.
+
+;; NS records cause both the usual additional section processing to locate
+;; a type A record, and, when used in a referral, a special search of the
+;; zone in which they reside for glue information.
+
+;; The NS RR states that the named host should be expected to have a zone
+;; starting at owner name of the specified class.  Note that the class may
+;; not indicate the protocol family which should be used to communicate
+;; with the host, although it is typically a strong hint.  For example,
+;; hosts which are name servers for either Internet (IN) or Hesiod (HS)
+;; class information are normally queried using IN class protocols.
+
+;; 3.3.12. PTR RDATA format
+
+;;     +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
+;;     /                   PTRDNAME                    /
+;;     +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
+
+;; where:
+
+;; PTRDNAME        A <domain-name> which points to some location in the
+;;                 domain name space.
+
+;; PTR records cause no additional section processing.  These RRs are used
+;; in special domains to point to some other location in the domain space.
+;; These records are simple data, and don't imply any special processing
+;; similar to that performed by CNAME, which identifies aliases.  See the
+;; description of the IN-ADDR.ARPA domain for an example.
+
+;; 3.3.13. SOA RDATA format
+
+;;     +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
+;;     /                     MNAME                     /
+;;     /                                               /
+;;     +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
+;;     /                     RNAME                     /
+;;     +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
+;;     |                    SERIAL                     |
+;;     |                                               |
+;;     +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
+;;     |                    REFRESH                    |
+;;     |                                               |
+;;     +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
+;;     |                     RETRY                     |
+;;     |                                               |
+;;     +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
+;;     |                    EXPIRE                     |
+;;     |                                               |
+;;     +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
+;;     |                    MINIMUM                    |
+;;     |                                               |
+;;     +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
+
+;; where:
+
+;; MNAME           The <domain-name> of the name server that was the
+;;                 original or primary source of data for this zone.
+
+;; RNAME           A <domain-name> which specifies the mailbox of the
+;;                 person responsible for this zone.
+
+;; SERIAL          The unsigned 32 bit version number of the original copy
+;;                 of the zone.  Zone transfers preserve this value.  This
+;;                 value wraps and should be compared using sequence space
+;;                 arithmetic.
+
+;; REFRESH         A 32 bit time interval before the zone should be
+;;                 refreshed.
+
+;; RETRY           A 32 bit time interval that should elapse before a
+;;                 failed refresh should be retried.
+
+;; EXPIRE          A 32 bit time value that specifies the upper limit on
+;;                 the time interval that can elapse before the zone is no
+;;                 longer authoritative.
+
+;; MINIMUM         The unsigned 32 bit minimum TTL field that should be
+;;                 exported with any RR from this zone.
+
+;; SOA records cause no additional section processing.
+
+;; All times are in units of seconds.
+
+;; Most of these fields are pertinent only for name server maintenance
+;; operations.  However, MINIMUM is used in all query operations that
+;; retrieve RRs from a zone.  Whenever a RR is sent in a response to a
+;; query, the TTL field is set to the maximum of the TTL field from the RR
+;; and the MINIMUM field in the appropriate SOA.  Thus MINIMUM is a lower
+;; bound on the TTL field for all RRs in a zone.  Note that this use of
+;; MINIMUM should occur when the RRs are copied into the response and not
+;; when the zone is loaded from a master file or via a zone transfer.  The
+;; reason for this provison is to allow future dynamic update facilities to
+;; change the SOA RR with known semantics.
+
+
+;; 3.3.14. TXT RDATA format
+
+;;     +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
+;;     /                   TXT-DATA                    /
+;;     +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
+
+;; where:
+
+;; TXT-DATA
+
+;; TXT RRs are used to hold descriptive text.  The semantics of the text
+;; depends on the domain where it is found.
+
+(defbinary dns-header (:byte-order :big-endian)
+           ;; A 16 bit identifier assigned by the program that
+           ;; generates any kind of query. This identifier is copied
+           ;; the corresponding reply and can be used by the requester
+           ;; to match up replies to outstanding queries.
+           (id 0 :type 16)
+
+           ;; A one bit field that specifies whether this message is a
+           ;; query (0), or a response (1).
+           (qr 0 :type 1)
+
+           ;; A four bit field that specifies kind of query in this
+           ;; message. This value is set by the originator of a query
+           ;; and copied into the response. The values are:
+           ;;
+           ;; 0               a standard query (QUERY)
+           ;; 1               an inverse query (IQUERY)
+           ;; 2               a server status request (STATUS)
+           ;; 3-15            reserved for future use
+           (opcode 0 :type 4)
+
+           ;; Authoritative Answer - this bit is valid in responses,
+           ;; and specifies that the responding name server is an
+           ;; authority for the domain name in question section.
+           (aa nil :type 1)
+
+           ;; TrunCation - specifies that this message was truncated
+           ;; due to length greater than that permitted on the
+           ;; transmission channel.
+           (tc nil :type 1)
+
+           ;; Recursion Desired - this bit may be set in a query and
+           ;; is copied into the response.  If RD is set, it directs
+           ;; the name server to pursue the query recursively.
+           ;; Recursive query support is optional.
+           (rd nil :type 1)
+
+           ;; Recursion Available - this be is set or cleared in a
+           ;; response, and denotes whether recursive query support is
+           ;; available in the name server.
+           (ra nil :type 1)
+
+           ;; Reserved for future use. Must be zero in all queries and
+           ;; responses.
+           (z 0 :type 3)
+
+           ;; Response code - this 4 bit field is set as part of
+           ;; responses.  The values have the following
+           ;; interpretation:
+           ;; 0               No error condition
+           ;; 1               Format error - The name server was
+           ;;                 unable to interpret the query.
+           ;; 2               Server failure - The name server was
+           ;;                 unable to process this query due to a
+           ;;                 problem with the name server.
+           ;; 3               Name Error - Meaningful only for
+           ;;                 responses from an authoritative name
+           ;;                 server, this code signifies that the
+           ;;                 domain name referenced in the query does
+           ;;                 not exist.
+           ;; 4               Not Implemented - The name server does
+           ;;                 not support the requested kind of query.
+           ;; 5               Refused - The name server refuses to
+           ;;                 perform the specified operation for
+           ;;                 policy reasons.  For example, a name
+           ;;                 server may not wish to provide the
+           ;;                 information to the particular requester,
+           ;;                 or a name server may not wish to perform
+           ;;                 a particular operation (e.g., zone
+           ;;                 transfer) for particular data.
+           ;; 6-15            Reserved for future use.
+           (rcode 0 :type 4)
+
+           ;; an unsigned 16 bit integer specifying the number of
+           ;; entries in the question section.
+           (qdcount 0 :type 16)
+
+           ;; an unsigned 16 bit integer specifying the number of
+           ;; resource records in the answer section.
+           (ancount 0 :type 16)
+
+           ;; an unsigned 16 bit integer specifying the number of name
+           ;; server resource records in the authority records
+           ;; section.
+           (nscount 0 :type 16)
+
+           ;; an unsigned 16 bit integer specifying the number of
+           ;; resource records in the additional records section.
+           (arcount 0 :type 16))
+
+
+;; Representation of DNS QNAMEs.
+;;
+;; A QNAME can be either made up entirely of labels, which is
+;; basically a list of strings, or be terminated with a pointer to an
+;; offset within the original message.
+
+(deftype qname-field ()
+  '(or
+    ;; pointer
+    (unsigned-byte 14)
+    ;; label
+    string))
+
+(defstruct qname
+  (start-at 0 :type (unsigned-byte 14))
+  (names #() :type (vector qname-field)))
+
+;; Domain names in questions and resource records are represented as a
+;; sequence of labels, where each label consists of a length octet
+;; followed by that number of octets.
+;;
+;; The domain name terminates with the zero length octet for the null
+;; label of the root. Note that this field may be an odd number of
+;; octets; no padding is used.
+(declaim (ftype (function (stream) (values qname integer)) read-qname))
+(defun read-qname (stream)
+  "Reads a DNS QNAME from STREAM."
+
+  (let ((start-at (file-position stream)))
+    (iter (for byte next (read-byte stream))
+      ;; Each fragment is collected into this byte vector pre-allocated
+      ;; with the correct size.
+      (for fragment = (make-array byte :element-type '(unsigned-byte 8)
+                                       :fill-pointer 0))
+
+      ;; If the bit sequence (1 1) is encountered at the beginning of
+      ;; the fragment, a qname pointer is being read.
+      (let ((byte-copy byte))
+        (when (equal #b11 (lisp-binary/integer:pop-bits 2 8 byte-copy))
+          (let ((next (read-byte stream)))
+            (lisp-binary/integer:push-bits byte-copy 8 next)
+            (collect next into fragments result-type vector)
+            (sum 2 into size)
+            (finish))))
+
+      ;; Total size is needed, count for each iteration byte, plus its
+      ;; own value.
+      (sum (+ 1 byte) into size)
+      (until (equal byte 0))
+
+      ;; On each iteration, this will interpret the current byte as an
+      ;; unsigned integer and read from STREAM an equivalent amount of
+      ;; times to assemble the current fragment.
+      ;;
+      ;; Advancing the stream like this also ensures that the next
+      ;; iteration occurs on a new fragment or the final terminating
+      ;; byte.
+      (dotimes (_ byte (collect (babel:octets-to-string fragment)
+                         into fragments result-type vector))
+        (vector-push (read-byte stream) fragment))
+
+      (finally (return (values (make-qname :start-at start-at
+                                           :names fragments)
+                               size))))))
+
+(declaim (ftype (function (stream qname)) write-qname))
+(defun write-qname (stream qname)
+  "Write a DNS qname to STREAM."
+
+  ;; Write each fragment starting with its (byte-) length, followed by
+  ;; the bytes.
+  (iter (for fragment in-vector (qname-names qname))
+    (for bytes = (babel:string-to-octets fragment))
+    (write-byte (length bytes) stream)
+    (iter (for byte in-vector bytes)
+      (write-byte byte stream)))
+
+  ;; Always finish off the serialisation with a null-byte!
+  (write-byte 0 stream))
+
+(define-enum dns-type 2
+    (:byte-order :big-endian)
+
+    ;; http://www.iana.org/assignments/dns-parameters/dns-parameters.xhtml
+    (A 1)
+    (NS 2)
+    (CNAME 5)
+    (SOA 6)
+    (PTR 12)
+    (MX 15)
+    (TXT 16)
+    (SRV 33)
+    (AAAA 28)
+
+    ;; ANY typically wants SOA, MX, NS and MX
+    (ANY 255))
+
+(defbinary dns-question (:byte-order :big-endian :export t)
+           ;; a domain name represented
+           (qname "" :type (custom :lisp-type qname
+                                   :reader #'read-qname
+                                   :writer #'write-qname))
+
+           ;; a two octet code which specifies the type of the query.
+           (qtype 0 :type dns-type)
+
+           ;; a two octet code that specifies the class of the query. For
+           ;; example, the QCLASS field is IN for the Internet.
+           (qclass 0 :type 16))
+
+(defbinary dns-rr (:byte-order :big-endian :export t)
+           (name nil :type (custom :lisp-type qname
+                                   :reader #'read-qname
+                                   :writer #'write-qname))
+
+           ;; two octets containing one of the RR type codes. This field
+           ;; specifies the meaning of the data in the RDATA field.
+           (type 0 :type dns-type)
+
+           ;; two octets which specify the class of the data in the RDATA
+           ;; field.
+           (class 0 :type 16)
+
+           ;; a 32 bit unsigned integer that specifies the time interval (in
+           ;; seconds) that the resource record may be cached before it should
+           ;; be discarded. Zero values are interpreted to mean that the RR
+           ;; can only be used for the transaction in progress, and should not
+           ;; be cached.
+           (ttl 0 :type 32)
+
+           ;; an unsigned 16 bit integer that specifies the length in octets
+           ;; of the RDATA field.
+           (rdlength 0 :type 16)
+
+           ;; a variable length string of octets that describes the resource.
+           ;; The format of this information varies according to the TYPE and
+           ;; CLASS of the resource record. For example, the if the TYPE is A
+           ;; and the CLASS is IN, the RDATA field is a 4 octet ARPA Internet
+           ;; address.
+           (rdata #() :type (eval (case type
+                                    ;; A 32-bit internet address in its
+                                    ;; canonical representation of 4 integers.
+                                    ((A) '(simple-array (unsigned-byte 8) (4)))
+
+                                    ;; TODO(tazjin): Deal with multiple strings in single RRDATA
+                                    ;; One or more <character-string>s.
+                                    ((TXT) '(counted-string 1))
+
+                                    ;; A <domain-name> which specifies the
+                                    ;; canonical or primary name for the
+                                    ;; owner. The owner name is an alias.
+                                    ((CNAME) '(custom
+                                               :lisp-type qname
+                                               :reader #'read-qname
+                                               :writer #'write-qname))
+
+                                    ;; A <domain-name> which specifies a host
+                                    ;; which should be authoritative for the
+                                    ;; specified class and domain.
+                                    ((NS) '(custom
+                                            :lisp-type qname
+                                            :reader #'read-qname
+                                            :writer #'write-qname))
+                                    (otherwise `(simple-array (unsigned-byte 8) (,rdlength)))))))
+
+(defbinary dns-message (:byte-order :big-endian :export t)
+           (header nil :type dns-header)
+
+           ;; the question for the name server
+           (question #() :type (simple-array dns-question ((dns-header-qdcount header))))
+
+           ;; ;; RRs answering the question
+           ;; (answer #() :type (simple-array (unsigned-byte 8) (16)))
+           (answer #() :type (simple-array dns-rr ((dns-header-ancount header))))
+
+           ;; ;; ;; RRs pointing toward an authority
+           (authority #() :type (simple-array dns-rr ((dns-header-nscount header))))
+
+           ;; ;; RRs holding additional information
+           (additional #() :type (simple-array dns-rr ((dns-header-arcount header)))))
diff --git a/lisp/dns/package.lisp b/lisp/dns/package.lisp
new file mode 100644
index 000000000000..2b8bfaa8bcc4
--- /dev/null
+++ b/lisp/dns/package.lisp
@@ -0,0 +1,11 @@
+(defpackage #:dns
+  (:documentation "Simple DNS resolver in Common Lisp")
+  (:use #:cl #:iterate #:lisp-binary)
+  (:export
+   ;; Individual lookup functions
+   #:lookup-txt #:lookup-mx #:lookup-cname #:lookup-a #:lookup-ns
+
+   ;; Useful accessors
+   #:dns-message-header #:dns-message-answer #:dns-message-question
+   #:dns-rr-name #:dns-rr-type #:dns-rr-ttl #:dns-rr-rdata
+   #:dns-question-qname #:dns-question-qtype))
diff --git a/lisp/klatre/OWNERS b/lisp/klatre/OWNERS
new file mode 100644
index 000000000000..ce7e0e37ee4f
--- /dev/null
+++ b/lisp/klatre/OWNERS
@@ -0,0 +1,3 @@
+inherited: true
+owners:
+  - grfn
diff --git a/lisp/klatre/default.nix b/lisp/klatre/default.nix
new file mode 100644
index 000000000000..2c7bb6490a9f
--- /dev/null
+++ b/lisp/klatre/default.nix
@@ -0,0 +1,14 @@
+{ depot, ... }:
+
+depot.nix.buildLisp.library {
+  name = "klatre";
+
+  deps = with depot.third_party.lisp; [
+    local-time
+  ];
+
+  srcs = [
+    ./package.lisp
+    ./klatre.lisp
+  ];
+}
diff --git a/lisp/klatre/klatre.lisp b/lisp/klatre/klatre.lisp
new file mode 100644
index 000000000000..79c7259752c6
--- /dev/null
+++ b/lisp/klatre/klatre.lisp
@@ -0,0 +1,119 @@
+(in-package #:klatre)
+(declaim (optimize (safety 3)))
+
+(defmacro comment (&rest _)
+  (declare (ignore _)))
+
+(defun posp (n) (> n 0))
+
+;;; Sequence utilities
+
+(defun slice (vector start end)
+  (make-array (- end start)
+              :element-type (array-element-type vector)
+              :displaced-to vector
+              :displaced-index-offset start))
+
+(defun chunk-vector (size vector &key start end sharedp)
+  (check-type size (integer 1))
+  (loop
+     with slicer = (if sharedp #'slice #'subseq)
+     and low = (or start 0)
+     and high = (or end (length vector))
+     for s from low below high by size
+     for e from (+ low size) by size
+     collect (funcall slicer vector s (min e high))))
+
+(defun chunk-list/unbounded (size list)
+  (loop
+     for front = list then next
+     for next = (nthcdr size front)
+     collect (ldiff front next)
+     while next))
+
+(defun chunk-list/bounded (size list upper-limit)
+  (loop
+     for front = list then next
+     for next = (nthcdr (min size upper-limit) front)
+     collect (ldiff front next)
+     do (decf upper-limit size)
+     while (and next (plusp upper-limit))))
+
+(defun chunk-list (size list &key (start 0) end)
+  "Returns successive chunks of list of size SIZE, starting at START and ending
+at END."
+  (declare (inline chunk-list/bounded chunk-list/unbounded))
+  (check-type size (integer 1))
+  (let ((list (nthcdr start list)))
+    (when list
+      (if end
+          (chunk-list/bounded size list (- end start))
+          (chunk-list/unbounded size list)))))
+
+(defun mapconcat (func lst sep)
+  "Apply FUNC to each element of LST, and concat the results as strings,
+separated by SEP."
+  (check-type lst cons)
+  (check-type sep (simple-array character (*)))
+  (let ((vs (make-array 0
+                        :element-type 'character
+                        :fill-pointer 0
+                        :adjustable t))
+        (lsep (length sep)))
+    (mapcar #'(lambda (str)
+                (let ((nstr (the (simple-array character (*))
+                                 (funcall func str))))
+                  (dotimes (j (length nstr) j)
+                    (vector-push-extend (char nstr (the fixnum j)) vs))
+                  (dotimes (k lsep k)
+                    (vector-push-extend (char sep (the fixnum k)) vs))))
+                lst)
+    vs))
+
+;;;
+;;; String handling
+;;;
+
+(defparameter dottime-format
+  '((:year 4) #\- (:month 2) #\- (:day 2)
+    #\T
+    (:hour 2) #\· (:min 2))
+  "`:LOCAL-TIME' format specifier for dottime")
+
+(defun format-dottime (timestamp &optional (offset 0))
+  "Return TIMESTAMP formatted as dottime, with a specified offset or +00"
+  (check-type timestamp local-time:timestamp)
+  (concatenate 'string
+    (local-time:format-timestring nil timestamp
+                                  :format dottime-format
+                                  :timezone local-time:+utc-zone+)
+    (format-dottime-offset offset)))
+
+(defun format-dottime-offset (offset)
+  "Render OFFSET in hours in the format specified by dottime."
+  (check-type offset integer)
+  (concatenate 'string
+    ; render sign manually since format prints it after padding
+    (if (>= offset 0) "+" "-")
+    (format nil "~2,'0D" (abs offset))))
+
+(comment
+ (format-dottime (local-time:now))
+ (format-dottime (local-time:now) 2))
+
+(defun try-parse-integer (str)
+  "Attempt to parse STR as an integer, returning nil if it is invalid."
+  (check-type str string)
+  (handler-case (parse-integer str)
+    (#+sbcl sb-int:simple-parse-error
+     #-sbcl parse-error (_) (declare (ignore _)) nil)))
+
+;;;
+;;; Function utilities
+;;;
+
+(defun partial (f &rest args)
+  "Return a function that calls F with ARGS prepended to any remaining
+  arguments"
+  (lambda (&rest more-args)
+    (apply f (append args more-args))))
diff --git a/lisp/klatre/package.lisp b/lisp/klatre/package.lisp
new file mode 100644
index 000000000000..41174bbb3cf7
--- /dev/null
+++ b/lisp/klatre/package.lisp
@@ -0,0 +1,16 @@
+(defpackage #:klatre
+  (:documentation "Grab-bag utility library for Common Lisp")
+  (:use #:cl)
+  (:export
+   ;; Miscellanious utilities
+   #:comment #:posp
+
+   ;; Sequence functions
+   #:chunk-list #:mapconcat
+
+   ;; String handling
+   #:+dottime-format+ #:format-dottime
+   #:try-parse-integer #:format-dottime-offset
+
+   ;; Function utilities
+   #:partial))