From bd274a20b46202f3a7d53a51a117cfd4110c3a67 Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Sat, 23 Jan 2021 17:18:10 -0700 Subject: new script: gmi2email Signed-off-by: Sean Whitton --- Makefile | 3 +- debian/changelog | 9 ++ debian/control | 8 ++ debian/copyright | 2 +- debian/mailscripts.install | 1 + debian/mailscripts.manpages | 1 + gmi2email | 272 ++++++++++++++++++++++++++++++++++++++++++++ gmi2email.1.pod | 81 +++++++++++++ mailscripts.el | 2 +- 9 files changed, 376 insertions(+), 3 deletions(-) create mode 100755 gmi2email create mode 100644 gmi2email.1.pod diff --git a/Makefile b/Makefile index e2ae233..6f52483 100644 --- a/Makefile +++ b/Makefile @@ -4,7 +4,8 @@ MANPAGES=mdmv.1 mbox2maildir.1 \ imap-dl.1 \ email-extract-openpgp-certs.1 \ email-print-mime-structure.1 \ - notmuch-import-patch.1 + notmuch-import-patch.1 \ + gmi2email.1 COMPLETIONS=completions/bash/email-print-mime-structure completions/bash/imap-dl all: $(MANPAGES) $(COMPLETIONS) diff --git a/debian/changelog b/debian/changelog index 5767aa8..bbb3bf5 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,12 @@ +mailscripts (0.23-1) UNRELEASED; urgency=medium + + * New script: gmi2email + - add libdbd-sqlite3-perl, libio-socket-ssl-perl, libmime-lite-perl, + libemail-date-format-perl, libtry-tiny-perl and libmailtools-perl to + Recommends. + + -- Sean Whitton Sat, 23 Jan 2021 16:36:25 -0700 + mailscripts (0.22-1) unstable; urgency=medium * mailscripts.el: diff --git a/debian/control b/debian/control index 3a549a3..a47be4c 100644 --- a/debian/control +++ b/debian/control @@ -51,6 +51,12 @@ Recommends: devscripts, git, libgit-wrapper-perl, + libdbd-sqlite3-perl, + libio-socket-ssl-perl, + libmime-lite-perl, + libemail-date-format-perl, + libtry-tiny-perl, + libmailtools-perl, notmuch, python3-argcomplete, python3-gssapi, @@ -85,3 +91,5 @@ Description: collection of scripts for manipulating e-mail on Debian email-extract-openpgp-certs -- extract OpenPGP certificates from a message . imap-dl -- download messages from an IMAP mailbox to a maildir + . + gmi2email -- subscribe to gemlogs and read individual Gemini pages by e-mail diff --git a/debian/copyright b/debian/copyright index db97f3d..1d246a9 100644 --- a/debian/copyright +++ b/debian/copyright @@ -1,7 +1,7 @@ mailscripts Collection of scripts for manipulating e-mail on Debian -Copyright (C)2017-2020 Sean Whitton +Copyright (C)2017-2021 Sean Whitton Copyright (C)2019-2020 Daniel Kahn Gillmor Copyright (C)2020 Red Hat, Inc. diff --git a/debian/mailscripts.install b/debian/mailscripts.install index df220b3..53665b3 100644 --- a/debian/mailscripts.install +++ b/debian/mailscripts.install @@ -8,3 +8,4 @@ mbox-extract-patch /usr/bin notmuch-extract-patch /usr/bin notmuch-import-patch /usr/bin notmuch-slurp-debbug /usr/bin +gmi2email /usr/bin diff --git a/debian/mailscripts.manpages b/debian/mailscripts.manpages index 345053a..d704a87 100644 --- a/debian/mailscripts.manpages +++ b/debian/mailscripts.manpages @@ -8,3 +8,4 @@ mbox-extract-patch.1 notmuch-extract-patch.1 notmuch-import-patch.1 notmuch-slurp-debbug.1 +gmi2email.1 diff --git a/gmi2email b/gmi2email new file mode 100755 index 0000000..c85728b --- /dev/null +++ b/gmi2email @@ -0,0 +1,272 @@ +#!/usr/bin/perl + +# gmi2email -- subscribe to gemlogs and read individual Gemini pages by e-mail + +# Copyright (C) 2021 Sean Whitton +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or (at +# your option) any later version. +# +# This program is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . + +use 5.028; +use strict; +use warnings; + +use DBI; +use File::Spec::Functions "catfile"; +use IO::Socket::SSL; +use MIME::Lite; +use Config::Tiny; +use Text::Wrap; +use Try::Tiny; +use Getopt::Long; +use Email::Date::Format "email_date"; +use Time::Local; +use Mail::Field::AddrList; + +my ($from, $to, $do_subs, $inline_images); +GetOptions + "from=s" => \$from, + "to=s" => \$to, + "subscriptions!" => \$do_subs, + "inline-images!" => \$inline_images; + +my $conf_r = $ENV{XDG_CONFIG_HOME} || catfile $ENV{HOME}, ".config"; +my $conf_f = catfile $conf_r, "mailscripts", "gmi2email.config"; +-e $conf_f + or (defined $to and defined $from) + or die + "no config file or sufficient command line options: don't know who to mail"; +my $conf = Config::Tiny->new->read($conf_f); + +my %to_mail_opts = ( + from => ( + $from + or $conf->{_}->{from} + or die "no From: address set in config or on command line" + ), + to => ( + $to + or $conf->{_}->{to} + or die "no To: address set in config or on command line" + ), + inline_images => $inline_images // $conf->{_}->{inline_images} // 0 +); + +@ARGV or $do_subs or die "nothing to do\n"; + +for (@ARGV) { + my $data; + if (-f) { + open my $fh, "<", $_; + $data = [<$fh>]; + } else { + my $type; + ($type, $data) = gemini_fetch($_, abs_links => 1); + $type =~ m{^text/gemini} or die "$_ is not gemtext"; + } + gemtext_to_mail($data, %to_mail_opts)->send; +} + +exit unless $do_subs; + +my $subs_f = catfile $conf_r, "mailscripts", "gmi2email.subscriptions"; +-e $subs_f or die "no list of subscriptions"; +open my $subs_fh, "<", $subs_f; + +my $db_r = $ENV{XDG_CACHE_HOME} || catfile $ENV{HOME}, ".cache"; +my $db_d = catfile $db_r, "mailscripts"; +-d $db_d or mkdir $db_d; +my $db_f = catfile $db_d, "gmi2email.db"; +my $dbh = DBI->connect("dbi:SQLite:dbname=$db_f", "", ""); +$dbh->do("CREATE TABLE IF NOT EXISTS seen (uri TEXT PRIMARY KEY)") + or die "failed to initialise database"; + +foreach my $sub (<$subs_fh>) { + chomp $sub; + my ($gemlog, $type, $data); + #<<< + try { + ($type, $data) = gemini_fetch($sub, abs_links => 1); + } catch { + my ($code) = /"gemini error: ([1-6])/; + if ($code == 4) { + warn "temporary failure retrieving $sub"; + next; # try again next run + } else { + die "while retrieving $sub $_"; + } + }; + #>>> + $type =~ m{^text/gemini} or die "$sub is not gemtext"; + for (@$data) { + if (/^#\s*/ and not $gemlog) { + chomp($gemlog = $'); + } elsif (my ($uri, $y, $m, $d, $title) + = /^=>\s*(\S+)\s+([0-9]{4})-([0-9]{2})-([0-9]{2})[\s-]*(.*)/) { + my ($rows) + = $dbh->selectrow_array( + "SELECT COUNT(*) FROM seen WHERE uri = \"$uri\""); + if ($rows == 0) { + my $mail = 1; + my ($type, $data); + #<<< + try { + ($type, $data) = gemini_fetch($uri, abs_links => 1); + } catch { + warn "when fetching $uri, $_"; + my ($code) = /"gemini error: ([1-6])/; + if ($code == 4) { + next; # try again next run + } else { + $mail = 0; # don't try this one again + } + }; + #>>> + $dbh->do("INSERT INTO seen VALUES (\"$uri\")"); + $mail or next; + if ($type =~ m{^text/gemini}) { + gemtext_to_mail( + $data, %to_mail_opts, + gemlog => $gemlog // "unknown gemlog", + link_title => $title, + date => email_date timelocal 0, + 0, 12, $d, $m - 1, $y + )->send; + } else { + warn "$uri is not gemtext"; + } + } + } + } +} + +sub gemini_fetch { + my ($uri, %opts) = @_; + + # regexp from Alex Schroeder's moku-pona program + my ($scheme, $authority, $path, $query, $fragment) + = $uri + =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|; + $scheme and $scheme eq "gemini" + or die "'$uri' does not use the gemini scheme"; + $authority or die "'$uri' lacks an authority"; + my ($host, $port) = split ":", $authority; + my $cl = IO::Socket::SSL->new( + PeerHost => $host, + PeerPort => $port // 1965, + SSL_verify_mode => SSL_VERIFY_NONE + ); + print $cl "$uri\r\n"; + + my ($status, $meta) = <$cl> =~ /^([0-9]+) (.+)/; + 20 <= $status and $status < 30 or die "gemini error: $status $meta"; + + if ($meta =~ "^text/gemini") { + my @lines; + if ($opts{abs_links}) { + $authority =~ m{/$} or $authority .= "/"; + $path =~ m{/$} or $path .= "/"; + for (<$cl>) { + s/\r?\n\z//; + if (m{^=> (?!/)} and not m{^=> [a-z]+://}) { + push @lines, "=> gemini://$authority$path$'"; + } elsif (m{^=> /}) { + push @lines, "=> gemini://$authority$'"; + } else { + push @lines, $_; + } + } + } else { + @lines = <$cl>; + } + push @lines, "" unless $lines[$#lines] eq ""; + push @lines, "Retrieved from $uri\n at " . localtime; + return $meta, \@lines; + } else { + return $meta, do { local $/; <$cl> }; + } +} + +sub gemtext_to_mail { + my ($gemtext, %opts) = @_; + $opts{from} or die "no From: address specified"; + $opts{to} or die "no To: address specified"; + + my $subject = $opts{link_title} // ""; + if ($gemtext->[0] =~ m{^#(?!#)\s*}) { + $subject = $'; + shift @$gemtext; + shift @$gemtext while $gemtext->[0] =~ /^$/; + } + + if ($opts{gemlog}) { + $opts{from} + = Mail::Field->new("From")->create($opts{from}, $opts{gemlog}) + ->stringify; + $subject = "$opts{gemlog}: $subject" if $subject; + } + + my $msg = MIME::Lite->new( + From => $opts{from}, + To => $opts{to}, + Subject => $subject, + Type => "multipart/mixed" + ); + $msg->add(Date => $opts{date}) if $opts{date}; + + my ($pre, @buffer); + my $flush = sub { + return unless @buffer; + $msg->attach(Type => "TEXT", Data => join "\r\n", @buffer); + undef @buffer; + }; + my $pad + = sub { push @buffer, "" unless !@buffer or $buffer[$#buffer] eq "" }; + for (@$gemtext) { + if ($pre) { + if (/^```/) { + $pre = 0; + } else { + push @buffer, " $_"; + } + } elsif (/^```/) { + &$pad; + $pre = 1; + } elsif (/^>\s*/) { + &$pad; + push @buffer, split "\n", wrap "> ", "> ", $'; + } elsif (/^\*\s*/) { + &$pad; + push @buffer, split "\n", wrap "• ", " ", $'; + } elsif ($opts{inline_images} + and my ($uri) = /^=>\s(\S+\.(?:jpg|jpeg|png|gif))\s/) { + &$flush; + my ($type, $data) = gemini_fetch($uri); + $msg->attach( + Type => $type, + Data => $data, + Filename => (split "/", $uri)[-1], + Disposition => "inline" + ); + } elsif (/^(?:=>|#+)/) { + &$pad; + push @buffer, $_; + } else { + &$pad; + push @buffer, split "\n", wrap "", "", $_; + } + } + + &$flush; + return $msg; +} diff --git a/gmi2email.1.pod b/gmi2email.1.pod new file mode 100644 index 0000000..5fa6d20 --- /dev/null +++ b/gmi2email.1.pod @@ -0,0 +1,81 @@ +=head1 NAME + +gmi2email - subscribe to gemlogs and read individual Gemini pages by e-mail + +=head1 SYNOPSIS + +B [I] [I] ... + +=head1 DESCRIPTION + +B fetches pages served using the Gemini protocol, converts them to +e-mail messages, and then sends those messages. It is mainly useful for +subscribing to Gemini logs ("gemlogs") by e-mail, like rss2email(1). +B fetches, converts and sends all URIs and files containing +text/gemini content specified on the command line. + +=head1 OPTIONS + +=over 4 + +=item B<--subscriptions> + +In addition to mailing any URIs/files specified on the command line, check +subscribed gemlogs for new posts and send those too. Useful in a crontab. + +Currently we only support the subscription mechanism described at +. + +B looks for a file with a list of gemini:// URIs to check for new +posts, one per line, in +B<$XDG_CONFIG_HOME/mailscripts/gmi2email.subscriptions>, or if XDG_CONFIG_HOME +is not set, it falls back to trying to read +B<~/.config/mailscripts/gmi2email.subscriptions>. + +=item B<--inline-images> + +Download and inline any images included in the post. + +=item B<--from=>I
+ +Set the From: address, overriding the configuration file. + +=item B<--to=>I
+ +Set the To: address, overriding the configuration file. + +=back + +=head1 CONFIGURATION + +B tries to read configuration from the file +B<$XDG_CONFIG_HOME/mailscripts/gmi2email.config>, or if XDG_CONFIG_HOME is not +set, it falls back to trying to read +B<~/.config/mailscripts/gmi2email.config>. + +The format is I, one per line. The following +configuration keys are supported: + +=over 4 + +=item B + +Set the From: address. + +=item B + +Set the To: address. + +=item inline_images + +Set to 1 to implicitly pass B<--inline-images>. + +=back + +=head1 SEE ALSO + + + +=head1 AUTHOR + +B was written by Sean Whitton . diff --git a/mailscripts.el b/mailscripts.el index 08947b5..8dc5875 100644 --- a/mailscripts.el +++ b/mailscripts.el @@ -1,7 +1,7 @@ ;;; mailscripts.el --- functions to access tools in the mailscripts package ;; Author: Sean Whitton -;; Version: 0.22 +;; Version: 0.23 ;; Package-Requires: (notmuch) ;; Copyright (C) 2018, 2019, 2020 Sean Whitton -- cgit v1.2.3