[dkm] An encrypting email client / messenger

  • 2 Replies
  • 872 Views
*

d.k

  • Novice
  • *
  • 19
[dkm] An encrypting email client / messenger
« on: January 14, 2017, 12:48:25 »
Hi,

since using PGP is quite a pain: I've implemented an encrypting email client or messenger if you like.
I've done the first parts.  It's working technically, but currently only with a single email account.
So, please have a try with a dummy account, since the credentials are sent in plain text to the email server.

Currently, I'm working on the encrypted database that shall replace the key files.

The plan is to evolve it into something like QuickMSG: http://quickmsg.vreeken.net
If someone likes to join in, I would create a project on sourceforge, etc.

Kind regards, d.k

PS: The first steps:
1. Fill in the server names and credentials.
2. Use rewrite-keys to create the keys and copy them into a folder "../keys".
3. Start with: 8th dkm.8th

Contents of dkm.8th:

Code: [Select]
     
\ GLOBALS
"[dkm]" var, title
"v0.02a" var, version
"<imap-server>" var, imap-server
"143" var, imap-port
"<smtp-server>" var, smtp-server
"587" var, smtp-port
"<email>" var, email
"<password>" var, passwd \ WARNING: Sent in plain text, beware!

\ DEBUG - todo use ns:dbg

true var, trace-flag

\ check data-stack
: dstack-filled? \ -- t/f
dstack st:len nip 1 n:> ;

\ print TOS
: XX dstack-filled?
if dup . cr then ;

: trace-on true trace-flag ! ;
: trace-off false trace-flag ! ;
: trace? trace-flag @ ;
: TRACE trace? if XX then ;
: BRK (interp) ; \ breakpoint



\ ENCRYPTION

"" var, msg
var key
var pkey
var skey
"../keys/pkey" var, pkey-fname
"../keys/skey" var, skey-fname
2048 var, key-len

: create-keys
key-len @ cr:rsagenkey
pkey !
skey ! ;

: create-file \ s --
 dup f:create
 f:err? ( if " file not created!" s:+ . bye else drop then ) exec ;

: write-file \ key filename --
f:open swap b:>base64 f:write drop f:close ;

: rewrite-keys
skey-fname @ f:exists? not if skey-fname @ create-file then
pkey-fname @ f:exists? not if pkey-fname @ create-file then
create-keys
skey @ skey-fname @ write-file
pkey @ pkey-fname @ write-file ;

: input-msg \ msg --
msg ! ;

: open-ro \ filename -- file
@ f:open-ro ;

: fail-check \ title-string --
swap null?
( if " failed!" s:+ . bye else 2drop then ) exec ;

: read-key \ filename -- file key
open-ro "" key-len @ f:read
"read" fail-check
\ convert base64-key to buffer
b:base64> ;

: encrypt-msg
pkey-fname read-key \ -- key-file
msg @ b:new \ -- key-file key msg
cr:rsa_encrypt msg !
f:close ;

: write-msg \ msg --
\ get plain message from user
input-msg
encrypt-msg ;

: decrypt-msg
skey-fname read-key \ -- key-file
msg @ b:new \ -- key-file key msg
cr:rsa_decrypt msg !
f:close ;

: show-msg
\ convert from buffer to string
msg @ >s cr . cr ;

: read-msg 
\ imap-read should have filled msg
decrypt-msg
show-msg ;





\ NET

var sock
0 var, cmd-counter
1 var, fetch-count
"" var, response
var responses
ns:a new responses !
"[start]" var, msg-start-tag
"[end]" var, msg-end-tag
4096 var, packet-len

: create-socket
net:INET4 net:STREAM net:socket sock ! ;

: open-connection \ host port --
create-socket
net:getaddrinfo
"Internet connection failed!" thrownull
sock @ net:connect
sock @ net:err?
0 = not ( if "Server connection failed!" . bye then ) exec ;

: close-connection
sock @ net:close ;

: prep-imap-cmd \ command -- prepared-command
\ prepare command with cmd-counter
1 cmd-counter n:+! cmd-counter @
"%>*08d " s:strfmt \ command counter-string
swap s:+ "\r\n" s:+ ;

: push-response \ s:response -- s:response
responses @ over a:push \ s -- s a
drop \ drop array
;

: send-cmd \ cmd -- socket
sock @ swap net:write drop ;

: get-response \ socket -- s:response
"" packet-len @ net:read drop ;

: icmd \ imap-command --
prep-imap-cmd
TRACE
send-cmd \ get socket
get-response
TRACE
push-response
response !
drop \ drop socket
;

: cmd \ command --
TRACE
send-cmd \ get socket
get-response
TRACE
response ! 
drop \ drop socket
;

: pcmd \ command -- prepared-command
"\n" s:+ cmd ;

: s-search \ haystack needle -- t/f
s:search null? not nip nip ;

: filter-search \ response -- true/false
"* SEARCH " s-search ;

: clear-responses
responses @ a:clear drop ;

\ returns null, if no mails were found
: get-search-response \ -- s:"* SEARCH "-response | null
responses @
' filter-search a:filter
a:len 0 n:=
if null
else \ drop out
  0 a:@ s:trim
then
nip \ drop array
;

: convert-search-response \ s -- a
\ replace all newlines to get an array
"\r\n" " " s:replace!
" " s:/ ;

: find-ok \ a -- ix
"OK" ' s:= a:indexof ;

: handle-ok-found
\ ["*","SEARCH","1","2","00000003","OK","SEARCH","completed"]
drop a:len 6 n:- ;
 
: handle-ok-not-found
\ ["*","SEARCH","1","2"]
drop a:len 2 n:- ;

: get-uids-only \ a1 -- a2
\ 3rd item is first uid and 2nd item before OK is last uid
find-ok null?
if handle-ok-not-found
else handle-ok-found then
2 swap a:slice ;

: apply-fetch-count \ a1 -- a2
\ uids: lo->hi, use fetch-count
a:len fetch-count @ n:min \ limit fetch count
dup n:neg swap \ from right to left
a:slice a:rev \ hi->lo
;

: create-msg-uids \ a -- a:uids
get-uids-only apply-fetch-count ;

: get-msg-uids \ -- a:uids
get-search-response null?
if
  drop
  "No mails found." . cr
  ns:a new \ return empty array
else
  convert-search-response
  create-msg-uids
then ;

: create-fetch-search \ uid -- s:search-needle
"%s FETCH" s:strfmt ;

: uid-filter \ uid s:response -- uid t/f
over create-fetch-search s-search ;

\ todo refactor!
: get-fetched-msg \ uid s:responses -- msg
swap create-fetch-search s:search \ uid s -- s min-ix
\ skip previous msgs
over s:len nip s:slice \ s min-ix --
msg-start-tag @ s:search \ s -- s ix
msg-start-tag @ s:len nip n:+ \ s ix -- s ixs
swap msg-end-tag @ s:search \ s ixs -- ixs s ixe
rot dup \ ixs s ixe -- s ixe ixs ixs
-rot n:- \ s ixe ixs ixs -- s ixs len
s:slice ;

: get-fetch-response \ uid -- s:response
\ get FETCH response with uid
drop responses @ >s "--" s:search \ uid -- s ix
' uid-filter a:filter 0 a:@ s:trim
nip ;

: get-msg-from-responses \ uid --
responses @ >s get-fetched-msg \ uid -- msg
s:base64> msg ! ;

: fetch \ uid --
"FETCH %s BODY[TEXT]" s:strfmt icmd ;

: .uid
"Message#: " . dup . cr ;

: ensure-fetch-msg
"NOOP" icmd 
"NOOP" icmd ;

: get-mail \ (used by a:each) ix uid --
nip dup
.uid
fetch \ uid uid -- uid
ensure-fetch-msg
get-msg-from-responses
read-msg ;

: add-email \ s -- s+email
email @ s:+ ;

: add-title \ s -- s+title
title @ s:+ ;

: add-version \ s -- s+version
version @ s:+ ;

: search-subject
"SEARCH SUBJECT " add-title add-version icmd ;

: search
search-subject
\ search a second time to make sure msg can be retrieved
search-subject ;

: open-inbox
imap-server @ imap-port @ open-connection
"LOGIN " add-email " " s:+ passwd @ s:+ icmd
"SELECT INBOX" icmd ;

: imap-get
open-inbox
search
get-msg-uids ' get-mail a:each drop
"CLOSE" icmd
"LOGOUT" icmd
close-connection
clear-responses \ for next call
;

: login
"AUTH LOGIN " email @ s:>base64 s:+ pcmd ;

: pass
passwd @ s:>base64 "\0" s:+ cmd ;

: plain
"AUTH PLAIN "
email @ "\x00" s:+
add-email
"\x00" s:+
passwd @ s:+
s:>base64 s:+ pcmd ;

: send-mail
"MAIL FROM: <" add-email "> AUTH=<>" s:+ pcmd
"RCPT TO: <" add-email ">" s:+ pcmd
"DATA" pcmd
"From: " add-email "\n" s:+
"To: " s:+ add-email "\n" s:+
"Subject: " s:+ add-title add-version "\n\n" s:+
msg-start-tag @ s:+
msg @ b:>base64 s:+
msg-end-tag @ s:+
"\r\n.\r\n" s:+ cmd ;

: hello
"EHLO " add-email pcmd ;

: quit
"QUIT" pcmd ;

: smtp-send
smtp-server @ smtp-port @ open-connection
hello
\ "STARTTLS" pcmd
\ hello
plain
send-mail
quit
close-connection ;

: send \ msg --
write-msg smtp-send ;

: get \ n --
fetch-count !
imap-get ;

\ test only
: g 20 get ;
: s "x1" send ;



\ MAIN

: help
cr
"Written in the programming language \"8th\" for sending and receiving
AES256-encrypted mails." . cr
"Currently, only one fixed mail-account is supported." . cr
"This allows for group communication with peers sharing this version of the
client." . cr
cr
"Usage: " . cr
"\"<message>\" send  --  send a message" . cr
"<number> get      --  get recent mails" . cr
"usage             --  this help" . cr
cr
"Examples: (\"ok>\" is a prompt)" . cr
cr
"ok> \"The secret message\" send" . cr
cr
"ok> 3 get" . cr
"    or replace 3 with the number " . cr
"    of recent mails you like to see." . cr
cr
"ok> bye " . cr
"    or press <CTRL-C> twice to quit." . cr
cr ;


: app:main
cr
" " add-title " - dkmail " s:+ add-version
"  --  Type \"help\" for help" s:+ . cr

(interp)
;
« Last Edit: January 14, 2017, 13:27:59 by d.k »

*

ron

  • Administrator
  • Guru
  • *****
  • 3,195
Re: [dkm] An encrypting email client / messenger
« Reply #1 on: January 14, 2017, 17:32:32 »
Nice work; when I've got the net libs fleshed out properly, it will be much easier to implement.

*

d.k

  • Novice
  • *
  • 19
Re: [dkm] An encrypting email client / messenger
« Reply #2 on: January 14, 2017, 18:08:58 »
Oh, that would be great!  :D