basis/bootstrap/image/upload/upload.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! Copyright (C) 2015 Doug Coleman.
   3 ! See https://factorcode.org/license.txt for BSD license.
   4 USING: arrays bootstrap.image checksums checksums.openssl
   5 hex-strings io io.directories io.encodings.ascii
   6 io.encodings.utf8 io.files io.files.temp io.files.unique
   7 io.launcher io.pathnames kernel make namespaces sequences
   8 splitting system unicode ;
   9 IN: bootstrap.image.upload
  10
  11 SYMBOL: upload-images-destination
  12 SYMBOL: build-images-destination
  13
  14 : latest-destination ( -- dest )
  15     upload-images-destination get
  16     "sheeple@downloads.factorcode.org:downloads.factorcode.org/images/master/"
  17     or ;
  18
  19 : build-destination ( -- dest )
  20     build-images-destination get
  21     "sheeple@downloads.factorcode.org:downloads.factorcode.org/images/build/"
  22     or ;
  23
  24 : factor-git-branch ( -- name )
  25     image-path parent-directory [
  26         { "git" "rev-parse" "--abbrev-ref" "HEAD" }
  27         utf8 <process-reader> stream-contents
  28         [ unicode:blank? ] trim-tail
  29     ] with-directory ;
  30
  31 : git-branch-destinations ( -- dests )
  32     build-images-destination get
  33     "sheeple@downloads.factorcode.org:downloads.factorcode.org/images/"
  34     or
  35     factor-git-branch dup { "master" "main" } member?
  36     [ drop { "master" "main" } ] [ 1array ] if
  37     [ "/" 3append ] with map ;
  38
  39 : checksums-path ( -- temp ) "checksums.txt" temp-file ;
  40
  41 : boot-image-names ( -- seq )
  42     image-names [ boot-image-name ] map ;
  43
  44 : compute-checksums ( -- )
  45     checksums-path ascii [
  46         boot-image-names [
  47             [ write bl ]
  48             [ openssl-md5 checksum-file bytes>hex-string write bl ]
  49             [ openssl-sha256 checksum-file bytes>hex-string print ]
  50             tri
  51         ] each
  52     ] with-file-writer ;
  53
  54 : scp-name ( -- path ) "scp" ;
  55
  56 : upload-images ( -- )
  57     git-branch-destinations [
  58         [
  59             [
  60                 \ scp-name get-global scp-name or ,
  61                 "-4" , ! force ipv4
  62                 boot-image-names %
  63                 checksums-path ,
  64             ] { } make
  65         ] dip suffix try-process
  66     ] each ;
  67
  68 : append-build ( path -- path' )
  69     vm-git-id "." glue ;
  70
  71 : checksum-lines-append-build ( -- )
  72     "checksums.txt" utf8 [
  73         [ " " split1 [ append-build ] dip " " glue ] map
  74     ] change-file-lines ;
  75
  76 : with-build-images ( quot -- )
  77     [ boot-image-names [ absolute-path ] map ] dip
  78     '[
  79         [
  80             ! Copy boot images
  81             _ "." copy-files-into
  82             ! Copy checksums
  83             checksums-path "." copy-file-into
  84             ! Rewrite checksum lines with build number
  85             checksum-lines-append-build
  86             ! Rename file to file.build-number
  87             "." directory-files [ dup append-build move-file ] each
  88             ! Run the quot in the unique directory
  89             @
  90         ] cleanup-unique-directory
  91     ] with-temp-directory ; inline
  92
  93 : upload-build-images ( -- )
  94     [
  95         [
  96             \ scp-name get-global scp-name or ,
  97             "-4" , ! force ipv4
  98             "." directory-files %
  99             build-destination ,
 100         ] { } make try-process
 101     ] with-build-images ;
 102
 103 : create-remote-upload-directory ( -- )
 104     '[
 105         "ssh" ,
 106         "-4" , ! force ipv4
 107         "sheeple@downloads.factorcode.org" ,
 108         "mkdir -p downloads.factorcode.org/images/" factor-git-branch append ,
 109     ] { } make try-process ;
 110
 111 : upload-new-images ( -- )
 112     [
 113         make-images
 114         "Computing checksums..." print flush
 115         compute-checksums
 116         "Creating remote directory..." print flush
 117         create-remote-upload-directory
 118         "Uploading images..." print flush
 119         upload-images
 120         "Uploading build images..." print flush
 121         upload-build-images
 122     ] with-resource-directory ;
 123
 124 MAIN: upload-new-images