Patch title: Release 85 bulk changes
Abstract:
File: /pliant/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/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"


constant frequency_sort true
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
function set_spam_mark filename spam
  arg Str filename ; arg CBool spam
  var FileInfo info := file_query filename standard
  var Str temp := file_temporary
  var Str temp := file_temporary
  file_copy filename temp
  (var Stream src) open temp in+safe
  (var Stream dest) open filename out+safe
  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
  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


  file_delete temp


function writedown spam mail filename
  arg Str filename ; arg (Dictionary Str Int) spam mail; arg
  var Str w ; var Int sf mf
  if frequency_sort
    var (Index Int Str) all
  else
    var (Index Str Str) all
  each p spam
    w := spam key p
    sf := p
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
  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)
    if exists:(mail first w)
      mf := mail w
      fmail := mail w
    else
    else
      mf := 0
    if frequency_sort
      all insert mf-sf w
    else
      all insert w w
  each p mail
    w := mail key p
    mf := p
      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)
    if not exists:(spam first w)
      sf := 0
      if frequency_sort
        all insert mf-sf w
      else
        all insert w 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
  (var Stream s) open filename out+safe
  s writeline "unknown_threshold "+string:unknown_threshold
  s writeline "spam_threshold "+string:spam_threshold
  each a all
    if exists:(spam first a)
  each a all
    if exists:(spam first a)
      sf := spam a
      fspam := spam a
    else
    else
      sf := 0
      fspam := 0
    if exists:(mail first a)
    if exists:(mail first a)
      mf := mail a
      fmail := mail a
    else
    else
      mf := 0
    s writeline a+" "+string:sf+" "+string:mf
      fmail := 0
    s writeline (string (all key a) "fixed 6")+" "+string:a+" "+string:fspam+" "+string:fmail


function load filename dict
  arg Str filename ; arg_rw (Dictionary Str Float) dict
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
  dict := gvar (Dictionary Str Float) empty_dict
  unkown_threshold := 0.5
  spam_threshold := 0.9
  (var Stream s) open filename in+safe
  while not s:atend
  (var Stream s) open filename in+safe
  while not s:atend
    if (s:readline parse any:(var Str w) _ (var Int sfreq) _
      # dict insert w (sfreq+1)/(mfreq+1)-(mfreq+1)/(sfreq+1
      dict insert w (log sfreq+1)-(log mfreq+1)
    var Str l := s readline
    if (l parse (var Float p) (var Str w) any)
      dict insert w p
    eif (l parse word:"unknown_threshold" (var Float f))
      unkown_threshold := f
    eif (l parse word:"spam_threshold" (var Float f))
      spam_threshold := f




function spam_ip_study path since list
  arg Str path ; arg DateTime since ; arg Str list
  var (Dictionary Str Int) spam_ips mail_ips
  var Array:FileInfo files := file_list path standard+recurs
  for (var Int i) 0 files:size-1
    if files:i:datetime>=since
      (var Stream s) open files:i:name in+safe
      var Str sender := ""
      var Pointer:(Dictionary Str Int) ips :> mail_ips
      while { var Str l := s readline ; l<>"" }
        if (l parse acword:"spam" any)
          ips :> spam_ips
        eif (l parse acword:"received" ":" any "[lb]" any:(v
          if (ip eparse (var Int i1) "." (var Int i2) "." (v
            sender := ip
      if sender<>""
        if not exists:(ips first sender)
          ips insert sender 0
        ips sender += 1
  writedown spam_ips mail_ips list
export spam_load_dictionary




function spam_ip_filter filename list -> rejected
  arg Str filename list ; arg CBool rejected
  load list (var (Dictionary Str Float) ips)
  var Str sender := ""
  (var Stream s) open filename in+safe
  while { var Str l := s readline ; l<>"" }
    if (l parse acword:"received" ":" any "[lb]" any:(var St
      if (ip eparse (var Int i1) "." (var Int i2) "." (var I
        sender := ip
  rejected := exists:(ips first sender) and ips:sender>0


export spam_ip_study spam_ip_filter


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


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


gvar (Array CBool 256) is_consonant
function setup_consonants
  for (var Int i) 0 255
    is_consonant i := false
  var Str consonants := "BCDFGHJKLMNPQRSTVWXZbcdfghjklmnpqrs
  for (var Int i) 0 consonants:len-1
    is_consonant consonants:i:number := true
setup_consonants

function is_text_line line -> valid
  arg Str line ; arg CBool valid
  var Int n := 0
  for (var Int i) 0 line:len-1
    if (is_consonant line:i:number)
      n += 1
      if n=4
        return false
    else   
      n := 0
  valid := true

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 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_count filename words
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
  arg Str filename ; arg_rw (Dictionary Str Int) words
  var (Dictionary Str Int) w
  (var Stream s) open filename in+safe
  (var Stream s) open filename in+safe
  while not s:atend
    var Str l := s readline
    if is_text_line:l
      var Int i := 0
      while i<l:len
        if l:i>="a" and l:i<="z" or l:i>="A" and l:i<="Z"
          var Int j := i+1
          while j<l:len and (l:j>="a" and l:j<="z" or l:j>="
            j += 1
          if j-i>=4 and j-i<=16
            var Str w := lower (l i j-i)
            if not exists:(words first w)
              words insert w 0
            words w += 1
            if words:size>50000
              var Int mini := 2
              while words:size>50000
                word_shrink words mini
                mini += 1
          i := j+1
        else
          i += 1
  (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
  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" 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_word_study path since list
  arg Str path ; arg DateTime since ; arg Str list
  var Array:FileInfo files := file_list path standard+recurs
  var (Dictionary Str Int) spam_words mail_words
  for (var Int i) 0 files:size-1
    if files:i:datetime>=since
      (var Stream s) open files:i:name in+safe
      var CBool spam := false
      while { var Str l := s readline ; l<>"" }
        if (l parse acword:"spam" any)
          spam := true
        eif (l parse acword:"subject" ":" any:(var Str subje
          if spam
            word_count files:i:name spam_words
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
  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
          else
          else
            word_count files:i:name mail_words
  word_shrink spam_words 3
  word_shrink mail_words 3
  writedown spam_words mail_words list
            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


constant limit (log 1e6)


function spam_word_filter filename list -> rejected
  arg Str filename list ; arg CBool rejected
  load list (var (Dictionary Str Float) words)
  var Float spam := 0
  (var Stream s) open filename in+safe
  while not s:atend
    var Str l := s readline
    var Int i := 0
    while i<l:len
      if l:i>="a" and l:i<="z" or l:i>="A" and l:i<="Z"
        var Int j := i+1
        while j<l:len and (l:j>="a" and l:j<="z" or l:j>="A"
          j += 1
        if j-i>=4 and j-i<=16
          var Str w := lower (l i j-i)
          if exists:(words first w)
            spam += words w
        i := j+1
      else
        i += 1
  rejected := spam>0
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


export spam_word_study spam_word_filter
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)
  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
  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)
  level := shunt rating>spam_threshold 1 rating>unknown_threshold 0 -1


export spam_study spam_filter spam_filter