#
# Copyright (c) 2018 LAAS/CNRS
# All rights reserved.
#
# Permission to use, copy, modify, and distribute this software for any purpose
# with or without   fee is hereby granted, provided   that the above  copyright
# notice and this permission notice appear in all copies.
#
# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH
# REGARD TO THIS  SOFTWARE INCLUDING ALL  IMPLIED WARRANTIES OF MERCHANTABILITY
# AND FITNESS. IN NO EVENT SHALL THE AUTHOR  BE LIABLE FOR ANY SPECIAL, DIRECT,
# INDIRECT, OR CONSEQUENTIAL DAMAGES OR  ANY DAMAGES WHATSOEVER RESULTING  FROM
# LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR
# OTHER TORTIOUS ACTION,   ARISING OUT OF OR IN    CONNECTION WITH THE USE   OR
# PERFORMANCE OF THIS SOFTWARE.
#
#                                            Anthony Mallet on Mon Sep 24 2018
#

variable bulk-url {
  robotpkg	http://robotpkg.openrobots.org/rbulk/robotpkg/
  robotpkg/wip	http://robotpkg.openrobots.org/rbulk/robotpkg-wip/
}


# --- db2mail --------------------------------------------------------------
#
proc db2mail { path db tag email sendmail } {
  global tcldir
  variable bulk-url

  if {$email eq ""} return

  set db [opendb $db]
  set date [clock format [clock seconds]]
  catch {
    set date \
        [clock format [$db eval "select date from session where tag = '$tag'"]]
  }
  set url ""
  catch { set url [dict get ${bulk-url} $path] }

  # generate statuses
  foreach status {broken warning sysdep na fixed} {
    sqlpkgstatus $db $tag $status $url msg
  }

  # generate message
  set count 0
  set text [list]
  foreach to {broken warning sysdep na fixed} {
    foreach from {new broken warning sysdep na fixed} {
      if {"$to,$from,count" in [array names msg]} {
        set header "<bold>"
        switch $to {
          broken  { append header "Broken packages" }
          warning { append header "Packaging warnings" }
          sysdep  { append header "Missing system dependencies" }
          na      { append header "Packages not available" }
          fixed   { append header "Fixed packages" }
        }
        append header "</bold>"
        switch $from {
          broken  { append header " (previously broken)" }
          warning { append header " (previously with packaging warnings)" }
          sysdep  { append header " (previously missing system dependencies)" }
          na      { append header " (previously not available)" }
          fixed   { append header " (previously OK)" }
          new     { append header " (new packages)" }
        }

        lappend text "\n"
        lappend text " * $header:\n"
        lappend text ""
        lappend text {*}$msg($to,$from)
        incr count $msg($to,$from,count)
      }
    }
  }

  # send message
  if {$count} {
    set out [open "|$sendmail" w]
    puts $out [join [subst {
      "From: Robert Bulk <robotpkg@laas.fr>"
      "To: $email"
      "Subject: \[rbulk $path\] $tag status report"
      "Auto-Submitted: auto-generated"
      "X-bulk-tag: $tag"
      "MIME-Version: 1.0"
      "Content-Type: text/enriched"
      ""
      "$tag bulk build status report for $path."
      ""
      "Report on $date, only changes since last message"
      "are shown."
    }] "\n"]
    puts $out [join $text "\n"]
    close $out
    puts "Sent $count status updates to $email."
  } else {
    puts "No status update since last run."
  }

  # clear fixed status
  $db eval {
    update meta set fixed = null where fixed is not null and
    id in (select id from pkg where tag = $tag)
  }

  # no need to analyze/vaccum
  closedb $db off
}


# --- sqlpkgstatus ---------------------------------------------------------
#
proc sqlpkgstatus { db tag status url msg& } {
  upvar ${msg&} msg
  set limit 255

  set extra ""
  if {$status in {broken warning na fixed}} {
    append extra " and (sysdep is null)"
  }
  if {$status in {warning na fixed}} { append extra " and (broken is null)" }
  if {$status in {na fixed}} { append extra " and (warning is null)" }
  if {$status in {fixed}} { append extra " and (na is null)" }

  $db eval [subst {
    select path, pkgname, fixed,
    group_concat(distinct (
      select by.pkgname from pkg as by natural join breaks as bby
      where bby.breaks = pkg.id)) as blist,
    count(breaks) as breaks, count(broken) as broken, count(warning) as warning
    from pkg natural join meta natural left outer join breaks
    where (tag = '$tag') and
    (fixed is not null) and ($status is not null) $extra
    group by pkgname
    order by breaks desc, broken desc, warning desc, pkgname
    limit $limit
  }] pkg {
    set change "unknown"
    catch {
      switch [binary format c $pkg(fixed)] {
        s  { set change "sysdep" }
        b  { set change "broken" }
        w  { set change "warning" }
        n  { set change "na" }
        \0 { set change "fixed" }
        \1 { set change "new" }
      }
    }

    set breaks ""
    if {$pkg(breaks) > 0} {
      append breaks " breaks $pkg(breaks) other package"
      if {$pkg(breaks) > 1} { append breaks "s" }
    } elseif {[string length $pkg(blist)]} {
      append breaks " broken by [join [split $pkg(blist) ,] {, }]"
    }

    set link ""
    if {$url ne "" && $status ni "fixed"} {
      set link ": $url$pkg(path)/index.html#$pkg(pkgname)"
    }

    lappend msg($status,$change) \
        "   - <bold>$pkg(pkgname)</bold> ($pkg(path))$breaks"
    lappend msg($status,$change) ""
    if {$url ne "" && $status ni "fixed"} {
      lappend msg($status,$change) \
          "     $url$pkg(path)/index.html#$pkg(pkgname)"
    lappend msg($status,$change) ""
    }

    incr msg($status,$change,count)
  }

  $db eval [subst {
    select count(distinct pkgname) as n
    from pkg natural join meta
    where (tag = '$tag') and
    (fixed is not null) and ($status is not null) $extra
  }] {
    if {$n > $limit} {
      lappend msg($status) "   - [expr {$n-$limit}] more packages not shown"
    }
  }
}
package provide rbulk-report 20260610
