Patch title: Release 87 bulk changes
Abstract:
File: /pliant/fullpliant/debian.pli
Key:
    Removed line
    Added line
abstract
  [This modules implements direct handling of Debian packages]
doc
  [You can think about it as a replacement of 'dpkg' and 'apt-get']

module "/pliant/language/unsafe.pli"
module "/pliant/language/stream.pli"
module "/pliant/admin/file.pli"
module "/pliant/admin/md5.pli"
module "/pliant/admin/execute.pli"
submodule "computer.pli"

module "/pliant/protocol/http/client.pli"
module "/pliant/protocol/ftp/client.pli"

(gvar TraceSlot debian_trace) configure "Debian install"


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


doc
  ['DebianPackage' type stores a record of a Debian .deb file.] ; eol


type DebianPackage
  field Str name version
  field Str repository section
  field Str priority ; field Float ring
  field Int size ; field Str md5
  field Str predepends depends
  field Str provides conflicts
  field Str url

type DebianDistribution
  field Str ftp_server <- "ftp.uk.debian.org"
  field Dictionary packages
  field Data:Computer computer


method p base_filename -> n
  arg DebianPackage p ; arg Str n
  n := p:name+"_"+(shunt (p:version parse any ":" any:(var Str v)) v p:version)+".deb"

method p base_section -> n
  arg DebianPackage p ; arg Str n
  n := shunt (p:section parse any "/" any:(var Str s)) s p:section

method p local_filename -> n
  arg DebianPackage p ; arg Str n
  n := "file:/fullpliant/debian/"+p:base_filename 

method p alternate_filename -> n
  arg DebianPackage p ; arg Str n
  n := "file:/fullpliant/debian_old/"+p:base_filename

method p remote_filename -> n
  arg DebianPackage p ; arg Str n
  n := p url


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


method debian load repository ring url
  arg_rw DebianDistribution debian ; arg Str repository ; arg Int ring ; arg Str url
  (var Stream list) open "gzip:file:/fullpliant/debian/packages_"+repository+".gz" in+safe
  var Link:DebianPackage p :> new DebianPackage
  while not list:atend
    var Str l := list readline
    if (l parse "Package" ":" any:(var Str name))
      p :> new DebianPackage
      p name := name
      p repository := repository
      p ring := ring
      debian:packages insert name false addressof:p
    if (l parse "Version" ":" any:(var Str version))
      p version := version
    if (l parse "Section" ":" any:(var Str section))
      p section := section
    if (l parse "Size" ":" (var Int size))
      p size := size
    if (l parse "MD5sum" ":" any:(var Str md5))
      p md5 := md5
    if (l parse "Pre-Depends" ":" any:(var Str predepends))
      p predepends := predepends
    if (l parse "Depends" ":" any:(var Str depends))
      p depends := depends
    if (l parse "Provides" ":" any:(var Str provides))
      p provides := provides
      while provides<>""
        if not (provides parse any:(var Str name) "," any:(var Str remain))
          name := provides ; remain := ""
        debian:packages insert name false addressof:p
        provides := remain
    if (l parse "Conflicts" ":" any (var Str conflicts))
      p conflicts := conflicts
    if (l parse "Priority" ":" any:(var Str priority))
      p priority := priority
      p ring := ring+(shunt priority="extra" 0.25 0)
    if (l parse "Filename" ":" any:(var Str path))
      if (url parse any:(var Str root) "/dists/" any)
        p url := root+"/"+path
      eif (url search ":" -1)<>(-1)
        p url := url+(path (path search_last "/" -1)+1 path:len)
      else
        p url := "ftp://"+debian:ftp_server+"/debian/"+path
  list close


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

doc
  link "Debian version numbering" "http://www.debian.org/doc/packaging-manuals/packaging.html/ch-versions.html"


function reorder s -> s2
  arg Str s s2
  if true
    s2 := s
  else
    s2 := ""
    for (var Int i) 0 s:len-1
      if s:i>="-"
        s2 += "0"+s:i
      eif s:i>="a" and s:i<="z"
        s2 += "1"+s:i
      eif s:i>="A" and s:i<="Z"
        s2 += "1"+(lower s:i)
      else
        s2 += "2"+(lower s:i)

function compare_version v1 v2 -> c
  arg Str v1 v2 ; arg Int c
  var Str s1 := replace v1 "-" "[0]" ; var Str s2 := replace v2 "-" "[0]"
  if (s1 search ":" -1)=(-1)
    s1 := "0:"+s1
  if (s2 search ":" -1)=(-1)
    s2 := "0:"+s2
  while s1<>"" or s2<>""
    if not (s1 parse any:(var Str t1) (var uInt i1) any:(var Str r1))
      t1 := s1 ; i1 := 0 ; r1 := ""
    if not (s2 parse any:(var Str t2) (var uInt i2) any:(var Str r2))
      t2 := s2 ; i2 := 0 ; r2 := ""
    c := compare reorder:t1 reorder:t2  
    if c<>compare_equal
      return    
    c := compare i1 i2
    if c<>compare_equal
      return
    s1 := r1 ; s2 := r2
  c := compare_equal

function satisfyed cond version -> ok
  arg Str cond version ; arg CBool ok
  if version=""
    return false
  if cond=""
    return true
  var Int flags ; var Str v
  if (cond parse ">=" any:v)
    flags := compare_superior+compare_equal
  eif (cond parse "<=" any:v)
    flags := compare_inferior+compare_equal
  eif (cond parse ">>" any:v)
    flags := compare_superior
  eif (cond parse "<<" any:v)
    flags := compare_inferior
  eif (cond parse "=" any:v)
    flags := compare_equal
  else
    return false
  ok := ((compare_version version v) .and. flags)<>0


method debian package name version cond err -> package
  arg DebianDistribution debian ; arg Str name version cond ; arg_w Str err ; arg Link:DebianPackage package
  var Float ring := 99 ; var Int count := 0
  var Pointer:Arrow c :> debian:packages first name
  while c<>null
    var Link:DebianPackage p :> c map DebianPackage
    if cond="latest" or (satisfyed cond p:version)
      if version="" or p:version=version
        var Float Int r := p ring
        if p:name=name
          r -= 0.5
        if r<ring or cond="latest" and ((compare_version p:version package:version) .and. compare_superior)<>0
          package :> p
          ring := r
          count := 1
        eif r=ring
          count += 1
    c :> debian:packages next name c
  if count<1
    package :> new DebianPackage
    err := "not found"
  eif count>1
    package :> new DebianPackage
    err := "ambigious"
    if cond<>""
      err += " for condition "+cond
    var Pointer:Arrow c :> debian:packages first name
    while c<>null
      var Link:DebianPackage p :> c map DebianPackage
      if (satisfyed cond p:version)
        if version="" or p:version=version
          var Float Int r := p ring
          if p:name=name
            r -= 0.5
          if r=ring
            err += " "+p:repository+" "+p:name+" "+p:version
      c :> debian:packages next name c
  else
    err := ""


method debian bind c
  arg_rw DebianDistribution debian ; arg Data:Computer c
  debian computer :> c
  debian ftp_server := c:env:"debian":"download":"ftp_server"
  if debian:ftp_server=""
    debian ftp_server := "ftp.uk.debian.org"
  each rep c:env:"debian":"repository"
    if rep<>""
      debian load keyof:rep (shunt (rep search "unstable" -1)<>(-1) 2 (rep search "testing" -1)<>(-1) 1 0) rep


method debian package name -> package
  arg DebianDistribution debian ; arg Str name ; arg Link:DebianPackage package
  package :> debian package name debian:computer:env:"package":name:"version" debian:computer:env:"package":name:"condition" (var Str err)


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

doc
  ['debian_select' function will use the Debian packages database as a source of dependencies rules, and add the missing required packages, and eventually detect a conflict.]


function debian_select c -> status
  arg_rw Data:Computer c ; arg ExtendedStatus status
  var Str computer_name := keyof c
  (var DebianDistribution debian) bind c
  each cursor debian:packages
    var Link:DebianPackage p :> cursor map DebianPackage
    if p:priority="required"
      c:env create "package"
      c:env:"package" create p:name
  status := failure
  var Dictionary provide
  each pkg c:env:"package"
    var Link:DebianPackage p :> debian package keyof:pkg pkg:"version" pkg:"condition" (var Str err)
    if err<>""
      return (failure "Could not find Debian package "+keyof:pkg+" "+pkg:"version"+" ("+err+")")
    if pkg:"version"=""
      pkg create "version"
      pkg:"version" := p version
    var Str provides := p provides
    while provides<>""
      if not (provides parse any:(var Str name) "," any:(var Str remain))
        name := provides ; remain := ""
      provide kmap name Bool := true
      provides := remain
  part complete
    var CBool more := false
    each pkg c:env:"package"
      part check_package
        var Link:DebianPackage p :> debian package keyof:pkg
        for (var Int lap) 0 1
          var Str depends := shunt lap=0 p:predepends p:depends
          while depends<>""
            if not (depends parse any:(var Str defs) "," any:(var Str remain))
              defs := depends ; remain := ""
            var Str alldefs := defs
            part study_one_condition
              if (defs parse any:(var Str def) "|" any:(var Str remain2))
                var CBool one := false
                while defs<>""
                  if not (defs parse any:(var Str def) "|" any:(var Str remain2))
                    def := defs ; remain2 := ""
                  if not (def parse any:(var Str name) "(" any:(var Str cond) ")")
                    name := def ; cond := ""
                  if (satisfyed cond c:env:"package":name:"version") or (cond="" and (provide kmap name Bool false))
                    one := true
                  defs := remain2
                if not one
                  # debian_trace trace "Condition "+alldefs+" requested by package "+p:name+" for computer "+computer_name+" is ambiguous"
                  alldefs parse  any:(var Str defs) "|" any:(var Str remain2)
                  restart study_one_condition
              else
                if not (defs parse any:(var Str name) "(" any:(var Str cond) ")")
                  name := defs ; cond := ""
                if (provide kmap name Bool false)
                  void
                eif not (exists c:env:"package":name)
                  var Link:DebianPackage q :> debian package name "" cond (var Str err)
                  if err=""
                    debian_trace trace "package " p:name " requires " q:name
                    c:env create "package"
                    c:env:"package" create q:name
                    c:env:"package":(q name) create "version"
                    c:env:"package":(q name):"version" := q version
                    var Str provides := q provides
                    while provides<>""
                      if not (provides parse any:(var Str name) "," any:(var Str remain2))
                        name := provides ; remain2 := ""
                      provide kmap name Bool := true
                      provides := remain2
                  else
                    return (failure "Cannot solve condition "+defs+" in package "+p:name+" for computer "+computer_name+" ("+err+")")
                  more := true
                eif not (satisfyed cond c:env:"package":name:"version")
                  var Link:DebianPackage q :> debian package name "" cond (var Str err)
                  if err="" and ((compare_version q:version c:env:"package":name:"version") .and. compare_superior)<>0
                    # we can solve the problem through increasing the target package version
                    debian_trace trace "package " pkg:name " forced package " name " from " c:env:"package":name:"version" " to " q:name
                    c:env:"package":name "version" := q version
                    more := true
                  else
                    if (cond parse "=" any:(var Str mversion))
                      var Link:DebianPackage q :> debian package name
                      if err="" and ((compare_version q:version p:version) .and. compare_superior)<>0
                        var Link:DebianPackage q :> debian package keyof:pkg q:version "" (var Str err)
                        if err=""
                          pkg "version" := q version
                          more := true 
                          restart check_package
                    var Link:DebianPackage q :> debian package keyof:pkg "" ">> "+pkg:"version" (var Str err)
                    if err=""
                      # try to increase the source package version
                      debian_trace trace "package " pkg:name " tries to raise itself from " pkg:"version" " to " q:version " in order to solve conflict with " name
                      pkg "version" := q version
                      more := true 
                      restart check_package
                    return (failure "Condition "+defs+" requested by package "+p:name+" for computer "+computer_name+" is unsatisfyed")
            depends := remain
    if more
      restart complete
  each pkg c:env:"package"
    check pkg:"version"<>"any"
    var Link:DebianPackage p :> debian package keyof:pkg
    check p:name<>""
    var Str conflicts := p conflicts
    while conflicts<>""
      if not (conflicts parse any:(var Str def) "," any:(var Str remain))
        def := conflicts ; remain := ""
        if not (def parse any:(var Str name) "(" any:(var Str cond) ")")
          name := def ; cond := ""
        if (satisfyed cond (debian package name):version)
          debian_trace trace "version is " (debian package name):version
          return (failure "Package "+p:name+" "+p:version+" conflicts with "+name+" for computer "+computer_name)
      conflicts := remain
  status := success
  data_store
  
export debian_select


function debian_upgrade c -> status
  arg Data:Computer c ; arg Status status
  status := success
  var Str ftp_server := c:env:"debian":"download":"ftp_server"
  if ftp_server=""
    ftp_server := "ftp.uk.debian.org"
  file_tree_create "file:/fullpliant/debian/"
  each rep c:env:"debian":"repository"
    if rep<>""
      if (rep search ":" -1)<>(-1)
        if (file_copy rep+"Packages.gz" "file:/fullpliant/debian/packages_"+keyof:rep+".gz" reduced)=failure
          status := failure
      else
        if (file_copy "ftp://"+ftp_server+"/debian/dists/"+rep+"Packages.gz" "file:/fullpliant/debian/packages_"+keyof:rep+".gz" reduced)=failure
          if (file_copy "ftp://"+ftp_server+"/debian-non-US/dists/"+rep+"Packages.gz" "file:/fullpliant/debian/packages_"+keyof:rep+".gz" reduced)=failure
            status := failure

export debian_upgrade


function debian_download c check -> status
  arg_rw Data:Computer c ; arg CBool check ; arg Status status
  status := success
  (var Stream log) open "file:/tmp/download.log" out+safe
  var Str computer_name := keyof c
  (var DebianDistribution debian) bind c
  var Dictionary download
  var Int count := 0
  var Int already := 0
  var Intn total := 0
  each pkg c:env:"package"
    part prepare
      var Str name := keyof pkg
      var Str version := pkg "version"
      var Link:DebianPackage p :> debian package name
      if p:name=""
        log writeline "Package "+name+" requested for computer "+computer_name+" is not available"
        status := failure
        leave prepare
      var FileInfo local := file_query p:local_filename standard
      var FileInfo alternate := file_query (replace p:local_filename "/fullpliant/debian/" "/fullpliant/debian.old/") standard
      if local=undefined and alternate=defined
        file_move alternate:name local:name
        local := file_query p:local_filename standard
      if local=undefined
        download kmap name Str := version
        count += 1
        total += p size
        debian_trace trace "package " pkg:name " needs to be downloaded"
      eif (shunt check (file_md5_hexa_signature local:name)<>(upper p:md5) local:size<>p:size)
        download kmap name Str := version
        count += 1
        total += p size
        debian_trace trace "package " p:name " is corrupted"
      else
        already += 1
  debian_trace trace already " ready to use packages."
  debian_trace trace count " packages to download (" total " bytes , " total\2^20 " MB)."
  console already " ready to use packages." eol
  console count " packages to download (" total " bytes , " total\2^20 " MB)." eol
  var DateTime start := datetime
  var Intn done := 0
  var Int failed := 0
  each version download type Str getkey name
    part download
      var Link:DebianPackage p :> debian package name
      if p:name=""
        log writeline "Package "+name+" to be downloaded for computer "+computer_name+" is not available"
        status := failure
        leave download
      debian_trace trace "download " p:base_section "/" p:base_filename
      console "download " p:base_section "/" p:base_filename " "
      var Str result := shunt (file_copy p:alternate_filename p:local_filename reduced+linktransparent)=success "ok" "FAILED"
      if result="FAILED"
        result := shunt (file_copy p:remote_filename p:local_filename reduced+linktransparent)=success "ok" "FAILED"
      if result="FAILED" and (p:remote_filename search "/debian/" -1)<>(-1)
        result := shunt (file_copy (replace p:remote_filename "/debian/" "/debian-non-US/") p:local_filename reduced+linktransparent)=success "ok" "FAILED"
      if result="ok"
        done += p size
      if (file_md5_hexa_signature p:local_filename)<>(upper p:md5)
        # file_delete p:local_filename
        if result="ok"
          result := "CORRUPTED"
      var Float elapsed := datetime:seconds-start:seconds
      if elapsed<=0.001
        elapsed := 0.001
      debian_trace trace result " " done*100\total "% " (cast (cast done Int)/elapsed Int) " cps"
      console result " " done*100\total "% " (cast (cast done Int)/elapsed Int) " cps" eol
      if result<>"ok"
        failed += 1
        status := failure
        console "  " p:remote_filename eol
  if count<>0
    debian_trace trace "downloaded " count-failed " packages" (shunt failed<>0 " out of "+string:count+" expected" "")
    console "downloaded " count-failed " packages" (shunt failed<>0 " out of "+string:count+" expected" "") eol
  if status=success
    file_delete "file:/tmp/download.log"

export debian_download


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

doc
  para
    ['debian_unpack' is roughly equivalent to] ; fixed [ dpkg-deb --extract] ; eol
    [It will create the following files in the path:]
    list
      item fixed:[control]
      item fixed:[data.tar.gz]
      item { fixed:[info/] ; italic [package_name] ; fixed [.list] }
      item { fixed:[info/] ; italic [package_name] ; fixed [.conffiles] }
      item { fixed:[info/] ; italic [package_name] ; fixed [.preinst] }
      item { fixed:[info/] ; italic [package_name] ; fixed [.postinst] }
      item { fixed:[info/] ; italic [package_name] ; fixed [.prerm] }
      item { fixed:[info/] ; italic [package_name] ; fixed [.postrm] }
      item { fixed:[info/] ; italic [package_name] ; fixed [.shlibs] }
      item { fixed:[info/] ; italic [package_name] ; fixed [.md5sums] }


method debian unpack1 name file path -> status
  arg DebianDistribution debian ; arg Str name file path ; arg Status status
  var Link:DebianPackage p :> debian package name
  if p:name=""
    return failure
  file_tree_delete path
  (var Stream deb) open (shunt file<>"" file p:local_filename) in+safe
  if deb=failure
    return failure
  var Str cmd := deb readline
  if cmd<>"!<arch>"
    return failure
  while not deb:atend
    var Str cmd := deb readline
    if (cmd parse any:(var Str filename) _ (var Int i1) (var Int uid) (var Int gid) (var Int i2) (var Int size) "`")
       (var Stream data) open path+filename out+mkdir
      var Int remain := size
      while remain>0 and { var Int step := raw_copy deb data 1 remain ; step>0 }
        remain -= step
      data close
    eif cmd:parse
      void
    else
      return failure
  (var Stream data) open path+"debian-binary" in+safe
  var Str ver := data readline
  if ver<>"2.0"
    return failure
  status := success


method debian unpack name file target -> status
  arg DebianDistribution debian ; arg Str name file target ; arg Status status
  var Str temp := file_temporary+"_package/"
  file_tree_delete temp
  if (debian unpack1 name file temp)=failure
    return failure
  file_tree_create temp+"info/"
  if (file_extract temp+"control.tar.gz" temp+"info/")=failure
    debian_trace trace "Failed to extract configuration files in Debian package " name
    return failure
  (var Stream control) open temp+"info/control" in
  var Str l := control readline
  if not (l parse "Package" ":" pattern:name)
    return failure
  file_tree_create target+"var/lib/dpkg/info/"
  if (execute "tar -zt -f "+file_os_name:temp+"data.tar.gz" output target+"var/lib/dpkg/info/"+name+".list")<>0
    return failure
  if (file_extract temp+"data.tar.gz" target)=failure
    return failure
  var Array:FileInfo files := file_list temp+"info/" standard+relative
  for (var Int i) 0 files:size-1
    if files:i:name<>"control"
      file_move temp+"info/"+files:i:name target+"var/lib/dpkg/info/"+name+"."+files:i:name
  (var Stream status1) open target+"var/lib/dpkg/status" in+safe
  (var Stream status2) open target+"var/lib/dpkg/status.tmp" out+mkdir+safe
  part scan_before
    while not status1:atend
      var Str l := status1 readline
      if (l parse "Package" ":" pattern:name)
        leave scan_before
      status2 writeline l
  part scan_drop
    while not status1:atend
      var Str l := status1 readline
      status2 writeline l
      if l=""
        leave scan_drop
  status2 writeline "Package: "+name
  status2 writeline "Status: install ok unpacked"
  while not control:atend
    var Str l := control readline
    if not (l parse "Architecture" ":" any)
      status2 writeline l
  if l<>""
    status2 writeline ""
  control close
  while not status1:atend
    status2 writeline status1:readline
  status1 close ; status2 close
  file_delete target+"var/lib/dpkg/status"
  file_move target+"var/lib/dpkg/status.tmp" target+"var/lib/dpkg/status"
  file_tree_delete temp
  status := success

export DebianDistribution '. bind' '. unpack1' '. unpack'