path: root/localmarkdown2sms

#!/usr/bin/perl
#
# /usr/local/sbin/localmarkdown2sms
# Copyright 2009-2010, Jonas Smedegaard <dr@jones.dk>
#
# Send series of messages through Kannel from simplified Markdown files

#  * Lines starting with "#" are "keywords" activating a message series
#    * write only a single word
#    * use each keyword only once across the whole system
#    * use only minuscles (not majuscles, i.e. CAPITAL LETTERS)
#  * Lines starting with "##" express pauses
#    * a pause is a number + a single letter, without spaces between
#    * a pause line can contain multiple pauses, separated by space

# Suggestion for writing style:
#
#  * Write explicitly how to activate next series
#  * pick keywords tied to nex series rather than the previous
#  * use same instruction jargon across all series in the system


use strict;
use warnings;

use Env qw[$debug $info $warn $dummy $nosleep $urldecode];
use Log::Log4perl qw(:easy);
use File::Spec;
use File::Slurp;
use Time::Duration::Parse;
use Text::Unidecode;
use Encode 2.12 qw(encode decode_utf8 _utf8_off); # need v2.12 to support coderef
use LWP::UserAgent;
use URI::Escape;
use Proc::Daemon;

# TODO: Use Coro instead
Proc::Daemon::Init unless ($debug);

my $sms_url = $ENV{SMS_URL} || "http://localhost:13013/cgi-bin/sendsms";
my $sms_usertag = $ENV{SMS_USERTAG} || "username";
my $sms_user = $ENV{SMS_USER} || "tester";
my $sms_pw = $ENV{SMS_PW} || "foobar";
my $sms_api = $ENV{SMS_API};
my $sms_callback = $ENV{SMS_CALLBACK};
my $sms_phone = $ENV{SMS_PHONE};
my $sms_errfrom = $ENV{SMS_ERRFROM} || $sms_phone;
my $sms_errto1 = $ENV{SMS_ERRTO1};
my $sms_errto2 = $ENV{SMS_ERRTO2};
my $sms_smsc = $ENV{SMS_SMSC};
my $sms_msgtag = $ENV{SMS_MSGTAG} || "text";
my $sms_cp = $ENV{SMS_CP} || "utf8";
my $sms_concatenation = $ENV{SMS_CONCATENATION};
my $sms_concat = $ENV{SMS_CONCAT};
my $sms_dlr_mask = $ENV{SMS_DLR_MASK};
my $sms_dlr_url = $ENV{SMS_DLR_URL};
my $sms_escalate = $ENV{SMS_ESCALATE};
my $sms_validity = $ENV{SMS_VALIDITY};
my $sms_req_feat = $ENV{SMS_REQ_FEAT};
my $sms_binfo = $ENV{SMS_BINFO};
my $stripprefix = $ENV{stripprefix};
my $path = $ENV{mdpath};

my (%file, %delay, %reply);

# decode data if passed from kannel
if ($urldecode) {
    @ARGV = uri_unescape(@ARGV);
}
my ($phone) = shift @ARGV;
my ($key) = lc (shift @ARGV);

# strip international prefix
# (prefix is optional some places and illegal at other places - forgot where)
if ($stripprefix) {
    $phone =~ s/^\+//g;
    $sms_phone =~ s/^\+//g;
    $sms_errfrom =~ s/^\+//g;
    $sms_errto1 =~ s/^\+//g;
    $sms_errto2 =~ s/^\+//g;
}

# strip non-word chars from keyword (and use only first chunk of word chars)
$key =~ s/.*?(\w+).*?/$1/;

if ($debug) {
    Log::Log4perl->easy_init($DEBUG);
} elsif ($INFO) {
    Log::Log4perl->easy_init($INFO);
} elsif ($WARN) {
    Log::Log4perl->easy_init($WARN);
} elsif ($ERROR) {
    Log::Log4perl->easy_init($ERROR);
}

unless ($path and -d $path) {
    ERROR "environment variable \"mdpath\" missing or wrong.";
    exit 1;
}

foreach my $file (read_dir( $path )) {
    my ($key, $i, $skipkeysection, $skipcontent);
    # suppress repeated warnings for same issue
    my ($warn_nonkey_delay, $warn_nonkey_content);
    next unless ($file =~ /\.mdwn$/);
    foreach my $line (read_file( File::Spec->catfile($path, $file))) {
    chomp $line;
    my $content;
    # headline
    if ($line =~ /^(#+)\s*(.*?)\s*$/) {
        # tidy latest reply
        if (defined($key) and defined($reply{$key}[$i])) {
            $reply{$key}[$i] = &tidymsg($reply{$key}[$i]);
            ($reply{$key}[$i]) || delete $reply{$key}[$i];
        }
        my $level = length($1);
        $content = $2;
        # key
        if ($level == 1 and $content =~ /(\w+)/) {
            $key = lc($1);
            $i = 0;
            $skipkeysection = undef;
            $skipcontent = undef;
            if (lc($content) ne $key) {
                WARN "key \"$key\" extracted from fuzzy string \"$content\" in file \"$file\"";
            }
            if (!defined( $delay{$key})) {
                $delay{$key}[0] = 0;
                $warn_nonkey_delay = undef;
                $warn_nonkey_content = undef;
            } else {
                WARN "skipping non-unique key \"$key\" in file \"$file\"";
                $key = undef;
                $skipkeysection = 1;
                $skipcontent = 1;
            }
        # delay
        } elsif ($level == 2 and $content =~ /((\d+[sm]\s?)+)/) {
            $skipcontent = undef;
            if (defined( $key)) {
                my $delay = parse_duration($1);
                if (defined($reply{$key}[$i])) {
                    $i++;
                    $delay{$key}[$i] = $delay{$key}[$i - 1];
                }
#               $delay{$key}[$i] += $delay; # accumulate: forked replies
                $delay{$key}[$i] = $delay; # simple: queued replies
                if ($content ne $1) {
                    WARN "delay (${delay}s) resolved from fuzzy string \"$content\" in file \"$file\"";
                }
            } elsif ($skipkeysection or $warn_nonkey_delay) {
                # skipping - already warned about it...
            } else {
                WARN "ignoring non-key'ed delay line \"$1\" in file \"$file\"";
                $warn_nonkey_delay = 1;
                $skipcontent = 1;
            }
        } else {
            WARN "ignoring non-parsable headline \"$line\" in file \"$file\"";
            $skipcontent = 1;
        }
    # reply
    } else {
        $content = $line . "\n";
        # ikiwiki directives - strip from content and parse for tags
        $content =~ s/(?<!\\)\[\[([^\[\]]*)(?<!\\)\]\]//gs and do {
            my $directive_string = $1;
            my ($directive, $directive_content);
            $directive_string =~ /^\s*\!(tag|taglink)\s*((\s*?\b\w+)+)/ and $file{$file}{'directive'}{'tag'} = [ split /\s+/, $2 ];
        };
        if ( defined( $key ) and not ($skipcontent)) {
            $reply{$key}[$i] .= $content;
        } elsif ($skipkeysection or $skipcontent or $warn_nonkey_content) {
            # skipping - already warned about it...
        } else {
            $content =~ /\S/s && WARN "skipping non-key'ed content \"$line\" in file \"$file\"";
            $warn_nonkey_content = 1;
        }
    }
    }
    # tidy latest reply
    if (defined($key) and defined($reply{$key}[$i])) {
    $reply{$key}[$i] = &tidymsg($reply{$key}[$i]);
    ($reply{$key}[$i]) || delete $reply{$key}[$i];
    }
}

sub tidymsg {
    my $msg = shift @_;
    $msg =~ s/^\h*$//g;         # clean virtually empty lines
    $msg =~ s/(\S)\h$/$1/g;         # strip single trailing space
    $msg =~ s/\n\n+/\n\n/g;         # strip excess newlines
    $msg =~ s/(\S)\n([^\n])/$1 $2/g;    # convert newline to space
    $msg =~ s/\h*$//g;          # strip all trailing spaces
    $msg =~ s/^\s*(\w*?.*?)\s*$/$1/s;   # strip surrounding space
    $msg =~ s/’/'/g;          #'simplify non-GSM chars
    $msg =~ s/…/.../g;            # simplify ellipsis
    $msg =~ s/\.\.+/.../g;          # multiple dots → psudo-ellipsis
    return $msg;
}

# based on Text::Unidecode bug#8017: http://rt.cpan.org/Ticket/Display.html?id=8017#txn-322351
sub transliterate {
    my ($tocharset, $string) = @_;

    my $res = encode($tocharset, decode_utf8($string), sub {
        my $ascii = unidecode(chr $_[0]);
        _utf8_off($ascii);
        $ascii;
        });

    return $res;
}

sub sendmsg {
    my ($from, $to, $desc, $msg) = @_;

    unless ($dummy) {
        my $ua = LWP::UserAgent->new(agent => "localmarkdown2sms");
        $ua->timeout(10);
        my $url = $sms_url
            . '?' . $sms_usertag . '=' . uri_escape($sms_user)
            . '&password=' . uri_escape($sms_pw)
            . '&to=' . uri_escape($to);
        $url .= '&api_id=' . uri_escape($sms_api) if ($sms_api);
        $url .= '&callback=' . uri_escape($sms_callback) if ($sms_callback);
        $url .= '&from=' . uri_escape($from) if ($from);
        $url .= '&smsc=' . uri_escape($sms_smsc) if ($sms_smsc);
        $url .= '&concatenation=true' if ($sms_concatenation);
        $url .= '&concat=' . uri_escape($sms_concat) if ($sms_concat);
        $url .= '&dlr-mask=' . uri_escape($sms_dlr_mask) if ($sms_dlr_mask);
        $url .= '&dlr-url=' . uri_escape($sms_dlr_url) if ($sms_dlr_url);
        $url .= '&escalate=' . uri_escape($sms_escalate) if ($sms_escalate);
        $url .= '&validity=' . uri_escape($sms_validity) if ($sms_validity);
        $url .= '&req_feat=' . uri_escape($sms_req_feat) if ($sms_req_feat);
        $url .= '&binfo=' . uri_escape($sms_binfo) if ($sms_binfo);
        $url .= '&' . $sms_msgtag . '=' . uri_escape(transliterate($sms_cp, $msg));
        DEBUG "Sending request: $url";
        my $response = $ua->request(HTTP::Request->new('GET', $url));
        unless ($response->is_success) {
            ERROR $response->status_line;
        }
        DEBUG "Done $desc";
    } else {
        print STDERR "\n  [$from --> $to: $desc]\n\n";
        print STDERR $msg . "\n";
    }
}

my $num_children = $#{ $reply{$key} } + 1;    # How many children we'll create

if (0 == $num_children) {
    my $err_en = "Sorry, not recognized as a keyword: Please check spelling and try again.";
    my $err_it = "Spiacente, non riconosco come parola chiave: Controlla l'ortografia e riprova.";
    &sendmsg($sms_phone, $phone, "fallback message", "$key?\n$err_it\n$err_en");
    ($sms_errto1) and &sendmsg($sms_errfrom, $sms_errto1, "warning", "[warning] $phone wrote: $key");
    ($sms_errto2) and &sendmsg($sms_errfrom, $sms_errto2, "warning", "[warning] $phone wrote: $key");
    exit;
}

if ($debug) {
    DEBUG "queueing $num_children replies:";
    for my $num ( 0 .. $num_children - 1 ) {
        DEBUG " [" . $delay{$key}[$num] . "s]";
    }
#   DEBUG "\n";
}
for my $num ( 0 .. $num_children - 1 ) {
    sleep($delay{$key}[$num]) unless ($nosleep);
    &sendmsg($sms_phone, $phone, "reply #$num [" . $delay{$key}[$num] . "s]", $reply{$key}[$num]);
}

1;