Verified Commit 1dd08465 authored by Luc Didry's avatar Luc Didry
Browse files

First version, working

parents
Pipeline #65634 failed with stage
in 21 seconds
public/*
*.swp
P6-Net-IMAP/lib/.precomp/*
image: framasoft/perl6-vrms:latest
stages:
- deploy
pages:
stage: deploy
script:
- ./vrms-web.pl6
artifacts:
paths:
- public
language: generic
env:
global:
- PATH=/opt/rakudo-pkg/bin:$PATH
matrix:
- VERSION=2018.03-01
branches:
except:
- gh-pages
before_install:
- sudo apt-get -qq update
- sudo apt-get install -y asciidoc
- cd $(mktemp -d)
- wget "https://github.com/nxadm/rakudo-pkg/releases/download/${TAG:-v${VERSION}}/rakudo-pkg-Ubuntu14.04_${VERSION}_amd64.deb" && sudo dpkg -i *.deb
- cd -
install:
- zef install --deps-only .
script: AUTHOR_TESTING=1 prove -v -e "perl6 -Ilib" t/
The MIT License (MIT)
Copyright (c) 2014 Andrew Egeler
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.
\ No newline at end of file
{
"perl" : "6.*",
"name" : "Net::IMAP",
"version" : "1.0.1",
"author" : "github:retupmoca",
"description" : "Simple IMAP Client",
"depends" : [ "Email::MIME", "IO::Socket::SSL" ],
"provides" : {
"Net::IMAP" : "lib/Net/IMAP.pm6",
"Net::IMAP::Raw" : "lib/Net/IMAP/Raw.pm6",
"Net::IMAP::Simple" : "lib/Net/IMAP/Simple.pm6",
"Net::IMAP::Message" : "lib/Net/IMAP/Message.pm6"
},
"source-url" : "git://github.com/retupmoca/P6-Net-IMAP.git"
}
P6-Net-IMAP
===========
An IMAP client library.
## Example Usage ##
my $i = Net::IMAP.new(:$server);
$i.authenticate($user, $pass);
$i.select('INBOX');
my @messages = $i.search(:all);
for @messages {
say .mime.header('subject');
}
## Simple interface methods ##
- `new(:$server, :$port = 143, :$debug, :$socket, :$ssl, :$starttls, :$plain)`
- `authenticate($user, $pass)`
- `mailboxes(:$subscribed)`
- `create($mailbox)`
- `delete($mailbox)`
- `rename($old-box, $new-box)`
- `subscribe($mailbox)`
- `unsubscribe($mailbox)`
- `select($mailbox)`
- `append($message)`
- `get-message(:$sid, :$uid)`
- `search(*%params)`
- `logout()`, `quit()`
### Net::IMAP::Message methods ###
- `sid`
- `uid`
- `flags(@new?)`
- `copy($mailbox)`
- `delete`
- `data`
- `mime-headers`
- `mime`
## Raw interface methods ##
- `get-response`
- `capability`
- `noop`
- `logout`
- `starttls`
- `switch-to-ssl`
- `login($user, $pass)`
- `select($mailbox)`
- `examine($mailbox)`
- `create($mailbox)`
- `delete($mailbox)`
- `rename($oldbox, $newbox)`
- `subscribe($mailbox)`
- `unsubscribe($mailbox)`
- `list($ref, $mbox)`
- `lsub($ref, $mbox)`
- `status($mbox, $type)`
- `append($name, $message, :$flags, :$datetime)`
- `check`
- `close`
- `expunge`
- `uid-search(*%query)`
- `search(*%query)`
- `uid-fetch($seq, $items)`
- `fetch($seq, $items)`
- `uid-store($seq, $action, $values)`
- `store($seq, $action, $values)`
- `uid-copy($seq, $mbox)`
- `copy($seq, $mbox)`
unit class Net::IMAP;
use Net::IMAP::Raw;
use Net::IMAP::Simple;
method new(:$server, :$port = 143, :$debug, :$raw, :$socket = IO::Socket::INET, :$ssl, :$starttls, :$plain) {
my role debug-connection {
method send($string){
my $tmpline = $string.substr(0, *-2);
note '==> '~$tmpline;
nextwith($string);
}
method get() {
my $line = callwith();
note '<== '~$line;
return $line;
}
};
if $raw {
my $conn = $socket.defined ?? $socket !! $socket.new(:host($server), :$port, :nl-in("\r\n"));
$conn = $conn but debug-connection if $debug;
$conn.nl-in = "\r\n";
return Net::IMAP::Raw.new(:conn($conn));
} else {
return Net::IMAP::Simple.new(:$ssl, :tls($starttls), :$plain, raw => Net::IMAP.new(:$server, :$port, :$debug, :$socket, :raw));
}
}
unit class Net::IMAP::Message;
use Email::MIME;
has $.imap;
has $.mailbox;
has $!sid;
has $!uid;
has $!flags;
has $!header-data;
has $!data;
has @!flags;
method new(:$imap, :$mailbox, :$sid, :$uid) {
my $self = self.bless(:$imap, :$mailbox);
$self._init($sid, $uid);
return $self;
}
method _init($sid, $uid) {
$!sid = $sid if $sid;
$!uid = $uid if $uid;
}
method mime-headers {
# XXX Very inefficient
return self.mime.header-obj;
}
method data {
unless $!data {
if $.mailbox ne $.imap.mailbox {
fail "Mailbox changed";
}
my $resp;
if $!uid {
$resp = $.imap.raw.uid-fetch($!uid, "BODY[]");
} else {
$resp = $.imap.raw.fetch($!sid, "BODY[]");
}
fail "Bad fetch" unless $resp ~~ /\w+\hOK\N+$/;
my @lines = $resp.split("\r\n");
my $bytes = 0;
my $seenbytes = 0;
my $data;
for @lines {
if /^\* \s+ \d+ \s+ FETCH .+ BODY\[\] \s+ \{(\d+)\}/ {
$bytes = $0.Int;
next;
}
if $bytes {
if $seenbytes >= $bytes {
$!data = $data;
return $!data;
}
$seenbytes += $_.chars + 2; # include \r\n line ending
$data ~= $_ ~ "\r\n";
}
}
}
return $!data;
}
method mime {
my $data = self.data;
return $data unless defined $data;
return Email::MIME.new($data);
}
method uid {
unless $!uid {
if $.mailbox ne $.imap.mailbox {
fail "Mailbox changed";
}
my $resp = $.imap.raw.fetch($!sid, "UID");
fail "Bad fetch" unless $resp ~~ /\w+\hOK\N+$/;
$resp ~~ /\* \s+ \d+ \s+ FETCH .+ UID \s+ (\d+)/;
$!uid = $0.Int;
}
return $!uid;
}
method sid {
unless $!sid {
if $.mailbox ne $.imap.mailbox {
fail "Mailbox changed";
}
my $resp = $.imap.raw.uid-fetch($!uid, "UID");
fail "Bad fetch" unless $resp ~~ /\w+\hOK\N+$/;
$resp ~~ /\* \s+ (\d+) \s+ FETCH .+ UID \s+/;
$!sid = $0.Int;
}
return $!sid;
}
multi method flags {
unless @!flags {
if $.mailbox ne $.imap.mailbox {
fail "Mailbox changed";
}
my $resp;
if $!uid {
$resp = $.imap.raw.uid-fetch($!uid, "FLAGS");
} else {
$resp = $.imap.raw.fetch($!sid, "FLAGS");
}
fail "Bad fetch" unless $resp ~~ /\w+\hOK\N+$/;
my @lines = $resp.split("\r\n");
@lines .= grep(/^\*\s+\d+\s+FETCH/);
@lines[0] ~~ /FLAGS\s+\((<-[\)]>*)\)/;
@!flags = $0.Str.words;
}
return @!flags;
}
multi method flags(@new) {
if $.mailbox ne $.imap.mailbox {
fail "Mailbox changed";
}
@!flags = @new;
my $resp;
if $!uid {
$resp = $.imap.raw.uid-store($!uid, 'FLAGS.SILENT', @new);
} else {
$resp = $.imap.raw.store($!sid, 'FLAGS.SILENT', @new);
}
fail "Bad store" unless $resp ~~ /\w+\hOK\N+$/;
return True;
}
method delete {
if $.mailbox ne $.imap.mailbox {
fail "Mailbox changed";
}
my @flags = self.flags;
@flags.push('\Deleted') unless @flags.grep(/\\Deleted/);
my $result = self.flags(@flags);
return $result unless $result;
$.imap.raw.expunge;
return True;
}
method copy($mailbox) {
if $.mailbox ne $.imap.mailbox {
fail "Mailbox changed";
}
my $resp;
if $!uid {
$resp = $.imap.raw.uid-copy($!uid, $mailbox);
} else {
$resp = $.imap.raw.copy($!sid, $mailbox);
}
fail "Bad copy" unless $resp ~~ /\w+\hOK\N+$/;
return True;
}
unit class Net::IMAP::Raw;
use IO::Socket::SSL;
has $.conn is rw;
has $.reqcode is rw = 'aaaa';
method get-response($code?){
my $line = $.conn.get;
return $line unless $code;
my $response = $line;
while $line.substr(0, $code.chars) ne $code {
$line = $.conn.get;
$response ~= "\r\n"~$line;
}
return $response;
}
method send($stuff) {
my $code = $.reqcode;
$.reqcode = $.reqcode.succ;
$.conn.print($code ~ " $stuff\r\n");
return self.get-response($code);
}
method switch-to-ssl() {
$!conn = IO::Socket::SSL.new(:client-socket($.conn), :input-line-separator("\r\n"));
$!conn.input-line-separator = "\r\n";
}
method starttls {
return self.send('STARTTLS');
}
method capability {
return self.send('CAPABILITY');
}
method noop {
return self.send('NOOP');
}
method logout {
return self.send('LOGOUT');
}
method login($user, $pass) {
return self.send("LOGIN $user $pass");
}
method select($mailbox) {
return self.send("SELECT $mailbox");
}
method examine($mailbox) {
return self.send("EXAMINE $mailbox");
}
method create($mailbox) {
return self.send("CREATE $mailbox");
}
method delete($mailbox) {
return self.send("DELETE $mailbox");
}
method rename($oldbox, $newbox) {
return self.send("RENAME $oldbox $newbox");
}
method subscribe($mailbox) {
return self.send("SUBSCRIBE $mailbox");
}
method unsubscribe($mailbox) {
return self.send("UNSUBSCRIBE $mailbox");
}
method list($ref, $mbox) {
return self.send("LIST $ref $mbox");
}
method lsub($ref, $mbox) {
return self.send("LSUB $ref $mbox");
}
method status($mbox, $type) {
return self.send("STATUS $mbox ({ $type.join(' ') })");
}
method append($name, $message, :$flags, :$datetime) {
my $code = $.reqcode;
$.reqcode = $.reqcode.succ;
my $string = "APPEND $name";
if $flags {
$string ~= " ({ $flags.join(' ') })";
}
if $datetime {
$string ~= " $datetime";
}
$.conn.send($code ~ " $string\r\n");
my $resp = self.get-response;
if $resp ~~ m:i/^\+\s/ {
$.conn.send($message);
return self.get-response($code);
} else {
unless $resp ~~ /^$code/ {
$resp ~= "\r\n" ~ self.get-response($code);
}
return $resp;
}
}
method check {
return self.send("CHECK");
}
method close {
return self.send("CLOSE");
}
method expunge {
return self.send("EXPUNGE");
}
method uid-search(*%query) {
return self.send("UID SEARCH "~self!generate-search-query(%query));
}
method search(*%query) {
return self.send("SEARCH"~self!generate-search-query(%query));
}
method !generate-search-query(%query) {
my $output;
if %query<charset> {
$output ~= " CHARSET %query<charset>";
}
for %query.kv -> $k, $v {
next unless $v;
given $k {
when any(<seq sid>) {
$output ~= " $v";
}
when 'not' {
$output ~= " NOT ({ self!generate-search-query($v) })";
}
when 'or' {
$output ~= " OR ({ self!generate-search-query($v[0]) })";
$output ~= " ({ self!generate-search-query($v[1]) })";
}
when any(<all answered deleted draft flagged new old recent seen unanswered undeleted undraft unflagged unseen>) {
$output ~= " " ~ $k.uc;
}
when any(<bcc before body cc from keyword larger on sentbefore senton sentsince since smaller subject text to uid unkeyword>) {
$output ~= " " ~ $k.uc ~ " $v";
}
when 'header' {
$output ~= " HEADER $v[0] $v[1]";
}
}
}
return $output;
}
method uid-fetch($seq, $items) {
return self.send("UID FETCH $seq ({ $items.join(' ') })");
}
method fetch($seq, $items) {
return self.send("FETCH $seq ({ $items.join(' ') })");
}
method uid-store($seq, $action, $values) {
return self.send("UID STORE $seq $action ({ $values.join(' ') })");
}
method store($seq, $action, $values) {
return self.send("STORE $seq $action ({ $values.join(' ') })");
}
method uid-copy($seq, $mbox) {
return self.send("UID COPY $seq $mbox");
}
method copy($seq, $mbox) {
return self.send("COPY $seq $mbox");
}
unit class Net::IMAP::Simple;
use Net::IMAP::Message;
has $.raw;
has $.mailbox;
has @.capabilities;
method new(:$raw!, :$ssl, :$tls, :$plain){
$raw.switch-to-ssl() if $ssl;
my $greeting = $raw.get-response;
fail "Bad greeting" unless $greeting ~~ /^\*\s+[OK|PREAUTH]/;
my @capabilities = self.get_capabilities($raw);
if @capabilities.grep('STARTTLS') {
if !$ssl && !$plain {
my $resp = $raw.starttls;
if $resp ~~ /OK/ {
$raw.switch-to-ssl;
@capabilities = self.get_capabilities($raw);
}
elsif $tls {
fail "STARTTLS failed: " ~ $resp;
}
}
}
else {
fail "Server doesn't support STARTTLS" if $tls;
}
my $self = self.bless(:$raw, :capabilities(@capabilities));
return $self;
}
method get_capabilities($raw) {
my @cap_lines = $raw.capability.split("\r\n");
my @capabilities;
for @cap_lines -> $line is rw {
if $line ~~ s/^\*\sCAPABILITY\s// {
@capabilities.append($line.split(/\s+/).grep({ $_ }));
}
}
return @capabilities;
}
method quit {
$.raw.logout;
$.raw.conn.close;
return True;
}
method logout { self.quit }
method get-message(:$uid, :$sid) {
if $uid {
return Net::IMAP::Message.new(:imap(self), :mailbox($.mailbox), :$uid);
} else {
return Net::IMAP::Message.new(:imap(self), :mailbox($.mailbox), :$sid);
}
}
method search(*%params) {
my $resp = $.raw.search(|%params);
fail "Bad search" unless $resp ~~ /\w+\hOK\N+$/;
my @lines = $resp.split("\r\n");
@lines .= grep(/^\*\h+SEARCH/);
my @messages = @lines[0].comb(/\d+/);
@messages .= map({ Net::IMAP::Message.new(:imap(self), :mailbox($.mailbox), :sid($_)) });
return @messages;
}
method select($mailbox) {
$!mailbox = $mailbox;