diff options
Diffstat (limited to 'lisp')
| -rw-r--r-- | lisp/dns/README.md | 75 | ||||
| -rw-r--r-- | lisp/dns/client.lisp | 85 | ||||
| -rw-r--r-- | lisp/dns/default.nix | 21 | ||||
| -rw-r--r-- | lisp/dns/message.lisp | 407 | ||||
| -rw-r--r-- | lisp/dns/package.lisp | 11 | ||||
| -rw-r--r-- | lisp/klatre/OWNERS | 1 | ||||
| -rw-r--r-- | lisp/klatre/default.nix | 14 | ||||
| -rw-r--r-- | lisp/klatre/klatre.lisp | 119 | ||||
| -rw-r--r-- | lisp/klatre/package.lisp | 16 |
9 files changed, 749 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..d2800bc9413a --- /dev/null +++ b/lisp/klatre/OWNERS @@ -0,0 +1 @@ +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)) |