Patch title: Release 91 bulk changes
Abstract:
File: /appli/backup/engine.pli
Key:
    Removed line
    Added line
# Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License version 2
# as published by the Free Software Foundation.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# version 2 along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.

submodule "/pliant/appli/database.pli"
submodule "/pliant/appli/database/split.pli"
module "/pliant/language/unsafe.pli"
module "/pliant/language/schedule/namedsem.pli"
module "/pliant/language/stream.pli"
module "/pliant/admin/file.pli"
module "/pliant/admin/md5.pli"
module "/pliant/admin/execute.pli"
module "/pliant/linux/kernel/module.pli"
module "/pliant/fullpliant/this_computer.pli"
module "/pliant/util/crypto/intn.pli"
module "/pliant/linux/storage/cdrom.pli"
module "/pliant/linux/storage/filesystem.pli"

constant log_report true
constant remote_engraving true
constant log_growth_mb (min (cast filesystem_query:"security:/backup.pdb":size\128\2^20 Int) 250) # assign up to 1% of disk, up to 250 MB

if remote_engraving
  module "engraving.remote"


public

  constant backup_ok 0
  constant backup_removed 1
  constant backup_lost 2
  constant backup_corrupted 3
  constant backup_temporary 4


public

  type BackupFileLine
    field DateTime datetime
    field Intn size <- 0
    field Str sign
    field DateTime when
    field Str medium
    field Int failure <- 0
    field Str history
    
  type BackupFile
    field DateTime datetime
    field Intn size <- 0
    field Str sign
    field DateTime when
    field Set:BackupFileLine line
    field Int status <- backup_ok
    field Str user
    field Str options
    field Str comment


  type BackupPath
    field Bool exclude <- false
    field Str disk
    field Str logical

  type BackupAreaLine
    field Bool once <- false
    field Int cycle <- undefined
    field Int pending_nb <- 0
    field Intn pending_size <- 0
    field DateTime pending_oldest
    field Int max_failures <- 0
    field Str medium

  type BackupArea
    field Set:BackupPath path
    field DateTime study
    field Int total_nb <- 0
    field Intn total_size <- 0
    field Int removed_nb <- 0
    field Intn removed_size <- 0
    field Int lost_nb <- 0
    field Intn lost_size <- 0
    field Int corrupted_nb <- 0
    field Intn corrupted_size <- 0
    field DateTime last_change
    field Set:BackupAreaLine line
    field Str options
    field Str comment
    split_field Set:BackupFile file
  
  type BackupLine
    field Str options
    field Str medium_header
    field Int medium_counter <- 1
    field Int total_nb <- 0
    field Intn total_size <- 0
    field Int removed_nb <- 0
    field Intn removed_size <- 0
    field Int lost_nb <- 0
    field Intn lost_size <- 0
    field Int corrupted_nb <- 0
    field Intn corrupted_size <- 0
    field Int pending_nb <- 0
    field Intn pending_size <- 0
    field DateTime pending_oldest
    field Int max_failures <- 0

  type BackupDatabase
    field Set:BackupArea area
    field Set:BackupLine line
   
  (gvar Database:BackupDatabase backup_database) load "security:/backup.pdb" mount "/pliant/backup"
  backup_database configure "encoding zlib"
  backup_database configure "growth "+(string log_growth_mb*2^20)


public

  type BackupMedium
    field Str medium
    field Intn free_space
    field Intn dir_space
    field List:FileInfo files
    field (Dictionary Str FileInfo) dict


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


method f available -> c
  arg Data:BackupFile f ; arg CBool c
  c := f:sign<>"" and (f:status=backup_ok or f:status=backup_temporary)

method f backup_required l al fl -> r
  arg Data:BackupFile f ; arg Data:BackupLine l ; arg Data:BackupAreaLine al ; arg Data:BackupFileLine fl ; arg CBool r
  r := fl:sign<>f:sign
  if al:cycle=defined and (fl:medium parse any (var Int num)) and l:medium_counter>=num+al:cycle
    r := true
  if not f:available
    r := false

method a backup_required f line_id -> r
  arg Data:BackupArea a ; arg Data:BackupFile f ; arg Str line_id ; arg CBool r
  r := f backup_required backup_database:data:line:line_id a:line:line_id f:line:line_id


method a disk_path subpath -> p
  arg Data:BackupArea a ; arg Str subpath ; arg Str p
  each ap a:path
    var Str logical := ap logical
    if (subpath 0 logical:len)=logical and not ap:exclude
      return ap:disk+(subpath logical:len subpath:len)
  p := ""

method a disk_path f -> p
  arg Data:BackupArea a ; arg Data:BackupFile f ; arg Str p
  p := a disk_path keyof:f


method l compute
  arg_rw Data:BackupLine l
  var Int tnb := 0 ; var Intn tsize := 0
  var Int rnb := 0 ; var Intn rsize := 0
  var Int lnb := 0 ; var Intn lsize := 0
  var Int cnb := 0 ; var Intn csize := 0
  var Int pnb := 0 ; var Intn psize := 0 ; var DateTime oldest := datetime ; var Int maxfail := 0
  var DateTime oldest := undefined
  var Int maxfail := 0
  each a backup_database:data:area
    var Data:BackupAreaLine al :> a:line keyof:l
    if exists:al
      tnb += a total_nb ; tsize += a total_size
      rnb += a removed_nb ; rsize += a removed_size
      lnb += a lost_nb ; lsize += a lost_size
      cnb += a corrupted_nb ; csize += a corrupted_size
      pnb += al pending_nb ; psize += al pending_size
      if oldest=undefined or al:pending_oldest<oldest
        oldest := al pending_oldest
      maxfail := max maxfail al:max_failures
  l total_nb := tnb ; l total_size := tsize
  l removed_nb := rnb ; l removed_size := rsize
  l lost_nb := lnb ; l lost_size := lsize
  l corrupted_nb := cnb ; l corrupted_size := csize
  l pending_nb := pnb ; l pending_size := psize
  l pending_oldest := oldest
  l max_failures := maxfail


method a compute
  arg_rw Data:BackupArea a
  var Int tnb := 0 ; var Intn tsize := 0
  var Int rnb := 0 ; var Intn rsize := 0
  var Int lnb := 0 ; var Intn lsize := 0
  var Int cnb := 0 ; var Intn csize := 0
  var DateTime lc := undefined
  each f a:file
    tnb += 1
    tsize += f size
    if f:status=backup_removed
      rnb += 1
      rsize += f size
    eif f:status=backup_lost
      lnb += 1
      lsize += f size
    eif f:status=backup_corrupted
      cnb += 1
      csize += f size
    if f:when=defined and (lc=undefined or f:when>lc)
      lc := f when
  a total_nb := tnb ; a total_size := tsize
  a removed_nb := rnb ; a removed_size := rsize
  a lost_nb := lnb ; a lost_size := lsize
  a corrupted_nb := cnb ; a corrupted_size := csize
  a last_change := lc
  each al a:line
    var Data:BackupLine l :> backup_database:data:line keyof:al
    var Int pnb := 0 ; var Intn psize := 0 ; var DateTime oldest := datetime ; var Int maxfail := 0
    var DateTime oldest := undefined
    var Int maxfail := 0
    each f a:file
      var Data:BackupFileLine fl :> f:line keyof:al
      if (f backup_required l al fl)
        pnb += 1 ; psize += f size
        if oldest=undefined or f:when<oldest
          oldest := f when
      maxfail := max maxfail fl:failure
    al pending_nb := pnb ; al pending_size := psize
    al pending_oldest := oldest
    al max_failures := maxfail
  each al a:line
    backup_database:data:line:(keyof al) compute


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


method a update options
  arg_rw Data:BackupArea a ; arg Str options
  var DateTime start := datetime
  var (Dictionary Str CBool) done
  each ap a:path
    var Str path := ap disk
    var Array:FileInfo files
    if ap:exclude
      files size := 0
    eif path:len>0 and (path path:len-1)="/"
      files := file_list path extended+recursive+relative
      for (var Int i) 0 files:size-1
        files:i:options := "logical "+(string ap:logical+files:i:name)+" "+files:i:options
        files:i name := path+files:i:name
    else
      files size := 1
      files 0 := file_query path extended
      files:0 options := "logical "+(string ap:logical)+" "+files:i:options
    for (var Int i) 0 files:size-1
      var Str logical := files:i:options option "logical" Str
      part update_file
        each ap2 a:path
          if ap2:exclude
            if ap2:disk<>"" and (files:i:name parse (pattern ap2:disk) any)
              leave update_file
            if ap2:logical<>"" and (logical parse (pattern ap2:logical) any)
              leave update_file
        if not files:i:is_link
          var Data:BackupFile f :> a:file logical
          if not exists:f
            a:file create logical
            f :> a:file logical
          if files:i:datetime<>f:datetime or files:i:size<>f:size or f:sign=""
            if (options option "modify")
              var Str sign := file_md5_hexa_signature files:i:name
              var FileInfo info := file_query files:i:name standard
              var CBool stable := info:datetime=files:i:datetime and info:size=files:i:size
              f datetime := info datetime
              f size := info size
              f sign := shunt stable sign ""
              f when := start
              f status := backup_ok
              f user := options option "user" Str
          eif (options option "checkup")
            var Str sign := file_md5_hexa_signature files:i:name
            var FileInfo info := file_query files:i:name standard
            if info:datetime=f:datetime and info:size=f:size and f:sign<>"" and sign<>f:sign
              f status := backup_corrupted
          done insert logical true
  each f a:file
    if not exists:(done first keyof:f)
      if (options option "delete")
        a:file delete keyof:f
      eif (options option "remove")
        f status := backup_removed
        f user := options option "user" Str
      else
        if f:status<>backup_removed
          f status := backup_lost
          f user := options option "user" Str
  a compute
  a study := start

method l update options
  arg_rw Data:BackupLine l ; arg Str options
  each a backup_database:data:area
    if (exists a:line:(keyof l))
      a update options

method f size m -> s
  arg Data:BackupFile f ; arg BackupMedium m ; arg Intn s
  s := f:size+m:dir_space

method a select line_id m force
  arg_rw Data:BackupArea a ; arg Str line_id ; arg_rw BackupMedium m ; arg CBool force
  var Data:BackupLine l :> backup_database:data:line line_id
  var Data:BackupAreaLine al :> a:line line_id
  if al:once
    var CBool required := false ; var Intn space := 0
    each f a:file
      if (f backup_required l al f:line:line_id)
        required := true
      if f:available
        space += f size m
    if required
      if space<=m:free_space
        each f a:file
          if f:available
            (var FileInfo info) name := a disk_path f
            info datetime := f datetime
            info size := f size
            info options := "cdname "+(string keyof:f)
            m files += info
            m free_space -= f size m
      eif force
        for (var Int lap) 0 1
          each f a:file
            var CBool br := f backup_required l al f:line:line_id
            if (shunt lap=0 br not br)
              if m:free_space>=(f size m)
                if f:available
                  (var FileInfo info) name := a disk_path f
                  info datetime := f datetime
                  info size := f size
                  info options := "cdname "+(string keyof:f)
                  m files += info
                  m free_space -= f size m
  else
    each f a:file
      if (f backup_required l al f:line:line_id)
        if m:free_space>=(f size m)
          (var FileInfo info) name := a disk_path f
          info datetime := f datetime
          info size := f size
          info options := "cdname "+(string keyof:f)
          m files += info
          m free_space -= f size m


method m complete -> total
  arg_rw BackupMedium m ; arg Intn total
  m dict := var (Dictionary Str FileInfo) empty_dictionary
  total := 0
  var Pointer:FileInfo file :> m:files first
  while exists:file
    m:dict insert (file:options option "cdname" Str) file
    total += file size
    file :> m:files next file


method a control line_id m path options log -> total
  arg_rw Data:BackupArea a ; arg Str line_id ; arg BackupMedium m ; arg Str path ; arg Str options ; arg_rw Stream log ; arg Int total
  var Str engraver := options option "engraver" Str
  if remote_engraving
    var Str remote_server := this_computer:env:"hardware":("engraver"+engraver):"remote"
  var Data:BackupLine l :> backup_database:data:line line_id
  var Data:BackupAreaLine al :> a:line line_id
  var DateTime now := datetime
  var CBool temporary := options option "temporary"
  total := 0
  each f a:file
    var Pointer:FileInfo expected :> m:dict first keyof:f
    if exists:expected
      var Data:BackupFileLine fl :> f:line line_id
      if not exists:fl
        f:line create line_id
        fl :> f:line line_id
      var Intn cd_size ; var Str cd_sign
      if remote_engraving and remote_server<>""
        cdrom_remote_control remote_server engraver keyof:f cd_size cd_sign
      else
        cd_size := (file_query path+keyof:f standard) size
        cd_sign := file_md5_hexa_signature path+keyof:f
      log writeline keyof:f+" "+(shunt cd_size=f:size and cd_sign=f:sign "ok" "failed")
      if cd_size=f:size and cd_sign=f:sign
        total += f size
        if not temporary
          fl datetime := f datetime
          fl size := f size
          fl sign := f sign
          fl when := now
          fl history := fl:history+(shunt fl:history<>"" and fl:medium<>"" " " "")+fl:medium
          fl medium := m medium
          fl failure := 0
          a:line:line_id medium := m medium
          if f:status=backup_temporary
            f status := backup_removed
            file_delete (a disk_path f)
      eif (options option "macintosh") and ("/"+keyof:f search "/.AppleDouble/" -1)<>(-1)
        total += f size
        if not temporary
          fl datetime := undefined
          fl size := 0
          fl sign := f sign
          fl when := now
          fl history := fl:history+(shunt fl:history<>"" and fl:medium<>"" " " "")+fl:medium
          fl medium := m medium
          fl failure := 0
          if f:status=backup_temporary
            f status := backup_removed
            file_delete (a disk_path f)
      else
        fl failure += 1
  a compute


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


gvar Sem engraver_sem
gvar NamedSem engraver_sem

method l engrave options0 -> status
  arg_rw Data:BackupLine l ; arg Str options0 ; arg ExtendedStatus status
  if not engraver_sem:nowait_request
    return failure:"There CD engraver is already running !"
  var Str options := options0+" "+l:options
  var Str engraver := options option "engraver" Str
  var Str engraver_id := this_computer:env:"hardware":("engraver"+engraver):"id"
  if not (engraver_sem nowait_request engraver_id)
    return failure:"There CD engraver is already running !"
  var Str engraver_medium := this_computer:env:"hardware":("engraver"+engraver):"medium"
  if engraver_medium=""
    engraver_medium := "cd"
  if remote_engraving
    var Str remote_server := this_computer:env:"hardware":("engraver"+engraver):"remote"
  if log_report
    var DateTime start := datetime
  var CBool temporary := options option "temporary"
  var Str id := keyof l
  var BackupMedium m
  m medium := l:medium_header+(string l:medium_counter)
  if not (this_computer:env:"hardware":("engraver"+engraver):"capacity_mb" parse (var Intn cd_capacity))
    cd_capacity := 650
    cd_capacity := shunt engraver_medium="dvd" 4812 650
  cd_capacity *= 2^20
  var Str all_options := options+" title "+(string m:medium)+(shunt temporary " rw" "")+" capacity_mb "+(string cd_capacity\2^20)+" buggy"
  var Intn free_space := cd_capacity-2^20
  var Intn free_space := cd_capacity*99\100
  part backup
    m free_space := free_space
    m dir_space := shunt (options option "indirect") 1024+256 4096
    m files := var List:FileInfo empty_list
    var CBool empty := true
    each a backup_database:data:area filter a:line:id:pending_nb>0 sort a:line:id:pending_oldest
      a select id m empty
      empty := false
    var Intn expected := m complete
    if m:dict:size<>0
      if remote_engraving and remote_server<>""
        if true
          status := cdrom_remote_engrave m:files all_options remote_server engraver
        else
          var Str isofile := file_temporary
          status := cdrom_image m:files all_options isofile
          if status=success
            cdrom_remote_record isofile all_options remote_server engraver
          file_delete isofile
      else
        status := cdrom_engrave m:files all_options
      if status=failure
        if (status:message parse (var Intn real_size) any) and real_size>cd_capacity
          free_space -= real_size-cd_capacity+2^20
          restart backup
        else
          leave backup
      sleep 15
      if log_report
        var DateTime intermediate := datetime
      if remote_engraving and remote_server<>""
        cdrom_remote_mount remote_server engraver
      else
        execute "insmod isofs" quiet
        kernel_load_module "isofs"
        if (filesystem_mount this_computer:env:"hardware":("engraver"+engraver):"device" "file:/mnt/backup"+engraver+"/" "filesystem [dq]iso9660[dq] readonly")=failure
          engraver_sem release
          engraver_sem release engraver_id
          return (failure "Failed to mount CDROM device "+this_computer:env:"hardware":("engraver"+engraver):"device"+" in order to check the freshly engraved backup")
      if not temporary
        l medium_counter += 1
      var Intn succeeded := 0
      part control "Checking CD "+m:medium+" content"
        (var Stream log) open "file:/tmp/backup.log" out+safe
        log writeline "medium "+m:medium
        log writeline ""
        each a backup_database:data:area filter a:line:id:pending_nb>0
          succeeded += a control id m "file:/mnt/backup"+engraver+"/" options log
        log close
      l compute
      if remote_engraving and remote_server<>""
        cdrom_remote_dismount remote_server engraver
      else
        filesystem_dismount "file:/mnt/backup"+engraver+"/"
      if log_report
        var DateTime final := datetime
        (var Stream log) open "file:/log/backup.log" append+safe
        log writeline "timestamp "+string:datetime
        log writeline "medium "+m:medium
        if temporary
          log writeline "temporary"
        if remote_engraving and remote_server<>""
          log writeline "on "+remote_server
        log writeline "elapsed "+string:(cast intermediate:seconds-start:seconds Int)+" + "+string:(cast final:seconds-intermediate:seconds Int)+" = "+string:(cast final:seconds-start:seconds Int)+" seconds"
        if (options option "indirect") and (status:message parse (var Intn iso) any)
          log writeline "iso9660 image "+string:iso+" ("+string:(cast iso\2^20 Int)+" MB)"
        log writeline "sucessfully engraved "+string:succeeded+" ("+string:(cast succeeded\2^20 Int)+" MB)"
        if succeeded<>expected
          log writeline "FAILED TO ENGRAVE "+(string expected-succeeded)+" ("+string:(cast (expected-succeeded)\2^20 Int)+" MB)"
        log writeline ""
        log close  
      status := success
    else
      status := failure "There is nothing to backup"
  if status=failure and log_report
    (var Stream log) open "file:/log/backup.log" append+safe
    log writeline "timestamp "+string:datetime
    log writeline "failure "+status:message
    log writeline ""
    log close  
  engraver_sem release
  engraver_sem release engraver_id


function backup_reset_failures
  each a backup_database:data:area
    each l1 a:line
      if l1:max_failures<>0
        each f a:file
          each l2 f:line
            if l2:failure<>0
              l2 failure := 0
        a compute
  each l backup_database:data:line
    l compute


export '. file'
export '. disk_path' '. backup_required'
export '. update' '. compute' '. engrave'
export backup_reset_failures


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


# rebuild database from CDs content
method l reprocess_cd -> status
  arg_rw Data:BackupLine l ; arg ExtendedStatus status
  var Str cd_label := filesystem_name this_computer:env:"hardware":"engraver":"device"
  if cd_label=""
    return failure:"Cannot get the CD volume ID"
  if (cd_label 0 l:medium_header:len)<>l:medium_header
    return (failure "CD volume ID is '"+cd_label+"'")
  execute "insmod isofs" quiet
  kernel_load_module "isofs"
  if (filesystem_mount this_computer:env:"hardware":"engraver":"device" "file:/mnt/backup/" "filesystem [dq]iso9660[dq] readonly")=failure
    engraver_sem release
    return (failure "Failed to mount CDROM device "+this_computer:env:"hardware":"engraver":"device"+" in order to check the freshly engraved backup")
  var Intn found := 0
  part control "Reprocessing CD "+cd_label+" content"
    each a backup_database:data:area
      var CBool concerned := false
      each ap a:path
        if (file_query "file:/mnt/backup/"+ap:logical standard+directories)=success
          concerned := true
      if concerned
        console "  processing area " keyof:a eol 
        each f a:file
          var FileInfo info := file_query "file:/mnt/backup/"+keyof:f standard
          if info=success and info:size=f:size and (file_md5_hexa_signature "file:/mnt/backup/"+keyof:f)=f:sign
            found += f size
            var Data:BackupFileLine fl :> f:line keyof:l
            if not exists:fl
              f:line create keyof:l
              fl :> f:line keyof:l
            if fl:medium<>cd_label
              fl datetime := f datetime
              fl size := f size
              fl sign := f sign
              fl when := undefined
              fl history := fl:history+(shunt fl:history<>"" and fl:medium<>"" " " "")+fl:medium
              fl medium := cd_label
              fl failure := 0
        a compute
  l compute
  filesystem_dismount "file:/mnt/backup/"
  status := success
  status message := "found "+string:found+" up to data bytes on CD ("+string:(cast found\2^20 Int)+" MB)"

function backup_reprocess_cd line_id cd_label -> status
  arg Str line_id cd_label ; arg ExtendedStatus status
  if (exists backup_database:data:line:line_id)
    status := backup_database:data:line:line_id reprocess_cd
  else
    status := failure "There is no '"+line_id+"' line in the backups database."
  console status:message eol

export '. reprocess_cd' backup_reprocess_cd