Patch title: Release 90 bulk changes
Abstract:
File: /protocol/smtp/spam.pli
Key:
    Removed line
    Added line
module "/pliant/admin/file.pli"
module "/pliant/language/unsafe.pli"
module "/pliant/language/stream.pli"
module "/pliant/math/functions.pli"
module "/pliant/util/encoding/html.pli"
module "mime.pli"

doc
  [The general algorithm is from ] ; link "Paul Graham" "http://www.paulgraham.com/spam.html" ; eol
  [Also it's highly likely that I failed to implement it properly.]


public
  gvar Int spam_hash_limit := 100000
  gvar CBool spam_shrink_dictionary := false
  gvar Int spam_select_count := 15
  gvar CBool spam_select_fixed := false

# assuming that 't' is the total number of mails and spams,
# that 'nr' is the number of rejected valid mails,
# and that 'na' the number of accepted spams,
# we basically have nr*na = cst
# now, if spam_threshold = 0.95, then we rougly get nr = na
# so spam_threshold = 0.99 is used to biase in order avoid rejecting valid mails
# finally, on my mails set, I got t/nr/na = 35


function set_spam_mark filename spam
  arg Str filename ; arg CBool spam
  var FileInfo info := file_query filename standard
  var Str temp := file_temporary
  if (file_copy filename temp)=success
    (var Stream src) open temp in+safe
    (var Stream dest) open filename out+safe
    # we have to write directly to filename instead of writing to temp, than renaming as usual, because the file is cloned
    var Str l := src readline
    if not spam and l="spam"
      void
    eif spam and l<>"spam"
      dest writeline "spam"
      dest writeline l
    else
      dest writeline l
    while (raw_copy src dest 1 2^24)<>0
      void
    src close ; dest close
    file_configure filename "datetime "+(string info:datetime)
  file_delete temp

export set_spam_mark


#-------------------------------------------------------------------------


function probability fspam nspam fmail nmail moderated -> f
  arg Int fspam nspam fmail nmail ; arg CBool moderated ; arg Float f
  f := fspam/nspam /( fspam/nspam + fmail/nmail )
  if moderated
    var Float e := exp -(1+fspam+fmail)
    f := e+(1-2*e)*f


function spam_write_dictionary spam nspam mail nmail filter unknown_threshold spam_threshold filename
  arg Str filename ; arg (Dictionary Str Int) spam ; arg Int nspam ; arg (Dictionary Str Int) mail ; arg Int nmail ; arg CBool filter ; arg Float unknown_threshold spam_threshold ; arg Str filename
function spam_write_dictionary spam nspam mail nmail filter html_adjust suspicious_adjust unknown_threshold spam_threshold filename
  arg Str filename ; arg (Dictionary Str Int) spam ; arg Int nspam ; arg (Dictionary Str Int) mail ; arg Int nmail ; arg CBool filter ; arg Float html_adjust suspicious_adjust unknown_threshold spam_threshold ; arg Str filename
  var Str w ; var Int fspam fmail
  var (Index Float Str) all
  each c spam
    w := spam key c
    fspam := c
    if exists:(mail first w)
      fmail := mail w
    else
      fmail := 0
    if not spam_shrink_dictionary or (abs 0.5-(probability fspam (max nspam 1) fmail (max nmail 1) filter))>=0.25
      all insert (probability fspam (max nspam 1) fmail (max nmail 1) true) w
  each c mail
    w := mail key c
    fmail := c
    if not exists:(spam first w)
      fspam := 0
      if not spam_shrink_dictionary or (abs 0.5-(probability fspam (max nspam 1) fmail (max nmail 1) filter))>=0.25
        all insert (probability fspam (max nspam 1) fmail (max nmail 1) true) w
  (var Stream s) open filename out+safe
  s writeline "html_adjust "+string:html_adjust
  s writeline "suspicious_adjust "+string:suspicious_adjust
  s writeline "unknown_threshold "+string:unknown_threshold
  s writeline "spam_threshold "+string:spam_threshold
  each a all
    if exists:(spam first a)
      fspam := spam a
    else
      fspam := 0
    if exists:(mail first a)
      fmail := mail a
    else
      fmail := 0
    s writeline (string (all key a) "fixed 6")+" "+string:a+" "+string:fspam+" "+string:fmail

function spam_load_dictionary filename dict unkown_threshold spam_threshold
  arg Str filename ; arg_w (Dictionary Str Float) dict ; arg_w Float unkown_threshold spam_threshold
function spam_load_dictionary filename dict html_adjust suspicious_adjust unkown_threshold spam_threshold
  arg Str filename ; arg_w (Dictionary Str Float) dict ; arg_w Float html_adjust suspicious_adjust unkown_threshold spam_threshold
  dict := gvar (Dictionary Str Float) empty_dict
  html_adjust := 0.5
  suspicious_adjust := 0.5
  unkown_threshold := 0.5
  spam_threshold := 0.9
  (var Stream s) open filename in+safe
  while not s:atend
    var Str l := s readline
    if (l parse (var Float p) (var Str w) any)
      dict insert w p
    eif (l parse word:"html_adjust" (var Float f))
      html_adjust := f
    eif (l parse word:"suspicious_adjust" (var Float f))
      suspicious_adjust := f
    eif (l parse word:"unknown_threshold" (var Float f))
      unkown_threshold := f
    eif (l parse word:"spam_threshold" (var Float f))
      spam_threshold := f


export spam_load_dictionary


#-------------------------------------------------------------------------


function word_shrink words minimum
  arg_rw (Dictionary Str Int) words ; arg Int minimum
  var List:Str discard
  each w words
    if w<minimum
      discard += words key w
  each d discard
    words remove words:d

function word_shrink words
  arg_rw (Dictionary Str Int) words
  var Int mini := 2
  while words:size>=spam_hash_limit
    word_shrink words mini
    mini += 1

method ms body_line2 l -> c
  arg_rw MimeStream ms ; arg_w Str l ; arg CBool c
  c := ms body_line l
  if not c
    return
  while { var Int i := l search "[lf]" -1 ; i=(-1) and l:len<1024 and (ms body_line (var Str l2)) }
    l += l2
  if i<l:len-1 and i<>(-1)
    ms unread (l i+1 l:len)
    l := l 0 i+1
  if ms:html
    l := html_decode l
    var Str tags := ""
    while { var Int i := l search "<" -1 ; i>=0 }
      var Int j := ((l i l:len) search ">" l:len-i)+i
      tags += l i j-i+1 
      l := (l 0 i)+(l j+1 l:len)
    l += tags
  if false
    console l eol

function word_count_line category l words
  arg Str category l ; arg_rw (Dictionary Str Int) words
  var Int i := 0
  while i<l:len
    var Int j := i+1
    if l:i>="a" and l:i<="z" or l:i>="A" and l:i<="Z"
      while j<l:len and (l:j>="a" and l:j<="z" or l:j>="A" and l:j<="Z")
        j += 1
      var Str w := category+lower:(l i j-i)
      var Pointer:Int c :> words first w
      if not exists:c
        word_shrink words
        words insert w 0
        c :> words first w
      c += 1
    i := j

function word_count_file filename words
  arg Str filename ; arg_rw (Dictionary Str Int) words
function word_count_file filename words html suspicious
  arg Str filename ; arg_rw (Dictionary Str Int) words ; arg_w CBool html suspicious
  suspicious := false
  var (Dictionary Str Int) w
  (var Stream s) open filename in+safe
  (var MimeStream ms) bind s true
  while (ms header_line (var Str l))
    if (l parse any:(var Str id) ":" any:(var Str value))
      ms_decode value
      word_count_line lower:id+" " id+": "+value w
      if id="Suspicious"
        suspicious := true
      else
        ms_decode value
        word_count_line lower:id+" " id+": "+value w
  html := ms:mime="text/html"
  suspicious := false
  while (ms body_line2 l)
    word_count_line "" l w
  if ms:multipart
    while not s:atend
      ms bind s false
      while (ms header_line l)
        if (l parse any:(var Str id) ":" any:(var Str value))
          ms_decode value
          word_count_line lower:id+" " id+": "+value w
      if ms:mime="text/html"
        html := true
      if ms:mime="text/html" or ms:mime="text/plain"
        while (ms body_line2 l)
          word_count_line "" l w
      else
        while (ms body_line l)
          void
  each p w
    var Str word := w key p
    var Pointer:Int c :> words first word
    if not exists:c
      word_shrink words
      words insert word 0
      c :> words first word
    c += 1

function spam_study path since unknown_threshold spam_threshold list
  arg Array:Str path ; arg DateTime since ; arg Float unknown_threshold spam_threshold ; arg Str list
function spam_study path since html_adjust suspicious_adjust unknown_threshold spam_threshold list
  arg Array:Str path ; arg DateTime since ; arg Float html_adjust suspicious_adjust unknown_threshold spam_threshold ; arg Str list
  var (Dictionary Str Int) spam_s ; var Int nspam := 0
  var (Dictionary Str Int) mail_words ; var Int nmail := 0
  var Int count := 0
  for (var Int p) 0 path:size-1
    var Array:FileInfo files := file_list path:p standard+recursive
    for (var Int i) 0 files:size-1
      if files:i:datetime>=since
        count += 1
  var Int current := 0
  for (var Int p) 0 path:size-1
    var Array:FileInfo files := file_list path:p standard+recursive
    for (var Int i) 0 files:size-1
      if files:i:datetime>=since
        current += 1
        part study "set mail filter "+string:current+"/"+string:count
          var Pointer:(Dictionary Str Int) words
          (var Stream s) open files:i:name in+safe
          if (s:readline parse word:"spam" any)
            word_count_file files:i:name spam_s ; nspam += 1
            word_count_file files:i:name spam_s (var CBool html) (var CBool suspicious) ; nspam += 1
          else
            word_count_file files:i:name mail_words ; nmail += 1
  spam_write_dictionary spam_s nspam mail_words nmail false unknown_threshold spam_threshold list
            word_count_file files:i:name mail_words (var CBool html) (var CBool suspicious) ; nmail += 1
  spam_write_dictionary spam_s nspam mail_words nmail false html_adjust suspicious_adjust unknown_threshold spam_threshold list

constant limit (log 1e6)

function transform p -> f
  arg Float p f
  if p<0.5
    f := (log 2*p)
    f := max f/limit -1
  else
    f := -(log 2*(1-p))
    f := min f/limit 1

function reverse f -> p
  arg Float p f
  if f<0
    p := (exp f*constant:limit)/2
  else
    p := 1-(exp -f*constant:limit)/2

function spam_filter filename words report -> spam
  arg Str filename ; arg (Dictionary Str Float) words ; arg_w Str report ; arg Float spam
  word_count_file filename (var (Dictionary Str Int) mw)
function spam_filter filename words html_adjust suspicious_adjust report -> spam
  arg Str filename ; arg (Dictionary Str Float) words ; arg Float html_adjust suspicious_adjust ; arg_w Str report ; arg Float spam
  word_count_file filename (var (Dictionary Str Int) mw) (var CBool html) (var CBool suspicious)
  var (Index Float Str) sorted
  each c mw
    var Str w := mw key c
    if exists:(words first w)
      var Float p := words w
      sorted insert -(abs 0.5-p) (string p "fixed 6")+" "+string:w+" ("+(string transform:p "fixed 2")+")"
  spam := 0 ; var Int n := 0 ; var Float last := -1
  var (Index Float Str) details
  part compute
    each s sorted
      s parse (var Float p) (var Str w) any
      if n>=spam_select_count and (spam_select_fixed or 0.5-(abs 0.5-p)>1/sorted:size) and p<>last
        leave compute
      spam += transform p ; n += 1
      details insert -p s
      last := p
  if n<>0
    spam := reverse spam/n
  else
    spam := 0.5
  spam := reverse transform:spam + transform:(shunt html html_adjust 0.5) + transform:(shunt suspicious suspicious_adjust 0.5)
  report := ""
  each d details
    report += d+"[lf]"

function spam_filter filename list -> level # -1 = regular mail, 0 = unkown, 1 = spam
  arg Str filename list ; arg Int level
  spam_load_dictionary list (var (Dictionary Str Float) words) (var Float unknown_threshold) (var Float spam_threshold)
  var Float rating := spam_filter filename words (var Str report)
  spam_load_dictionary list (var (Dictionary Str Float) words) (var Float html_adjust) (var Float suspicious_adjust) (var Float unknown_threshold) (var Float spam_threshold)
  var Float rating := spam_filter filename words html_adjust suspicious_adjust (var Str report)
  level := shunt rating>spam_threshold 1 rating>unknown_threshold 0 -1


export spam_study spam_filter spam_filter