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