basis/tools/deploy/backend/backend.factor

   1 ! Copyright (C) 2007, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs bootstrap.image hashtables io io.directories
   4 io.encodings.utf8 io.files io.files.temp io.launcher io.pathnames
   5 kernel locals make namespaces prettyprint sequences splitting system
   6 tools.deploy.config tools.deploy.config.editor tools.deploy.embed
   7 tools.deploy.libraries vocabs.loader vocabs.metadata.resources
   8 webbrowser ;
   9 IN: tools.deploy.backend
  10
  11 : copy-vm ( executable bundle-name -- vm-path )
  12     prepend-path vm-path over copy-file ;
  13
  14 TUPLE: vocab-manifest vocabs libraries ;
  15
  16 : copy-resources ( manifest name dir -- )
  17     append-path swap vocabs>> [ copy-vocab-resources ] with each ;
  18
  19 ERROR: can't-deploy-library-file library ;
  20
  21 : copy-library ( dir library -- )
  22     dup find-library-file
  23     [ swap over file-name append-path copy-file ]
  24     [ can't-deploy-library-file ] ?if ;
  25
  26 : copy-libraries ( manifest name dir -- )
  27     append-path swap libraries>> [ copy-library ] with each ;
  28
  29 : deployed-image-name ( vocab -- str )
  30     ".image" append temp-file ;
  31
  32 : copy-lines ( -- )
  33     readln [ print flush copy-lines ] when* ;
  34
  35 : run-with-output ( arguments -- )
  36     <process>
  37         swap >>command
  38         +stdout+ >>stderr
  39         +closed+ >>stdin
  40         +low-priority+ >>priority
  41     utf8 [ copy-lines ] with-process-reader ;
  42
  43 : make-boot-image ( -- )
  44     ! If stage1 image doesn't exist, create one.
  45     my-boot-image-name resource-path exists?
  46     [ make-my-image ] unless ;
  47
  48 : staging-image-name ( profile -- name )
  49     "-" join "." my-arch-name 3append
  50     "staging." ".image" surround cache-file ;
  51
  52 : delete-staging-images ( -- )
  53     cache-directory [
  54         [ "staging." head? ] filter
  55         "." my-arch-name ".image" 3append [ tail? ] curry filter
  56         [ delete-file ] each
  57     ] with-directory-files ;
  58
  59 : input-image-name ( profile -- name )
  60     but-last [ my-boot-image-name ] [ staging-image-name ] if-empty ;
  61
  62 : run-factor ( vm-path flags -- )
  63     swap prefix dup . run-with-output ; inline
  64
  65 : staging-command-line ( profile -- flags )
  66     [
  67         [
  68             "-staging" , "-no-user-init" , "-pic=0" ,
  69             [ staging-image-name "-output-image=" prepend , ]
  70             [ " " join "-include=" prepend , ] bi
  71         ] [
  72             input-image-name "-i=" prepend ,
  73             "-resource-path=" "" resource-path append ,
  74             "-run=tools.deploy.restage" ,
  75         ] bi
  76     ] { } make ;
  77
  78 : make-staging-image ( profile -- )
  79     { } [ suffix ] accumulate* [ staging-image-name exists? ] reject
  80     [ staging-command-line ] map
  81     [ vm-path swap run-factor ] each ;
  82
  83 : make-deploy-config ( vocab -- file )
  84     [ deploy-config vocab-roots get vocab-roots associate assoc-union unparse-use ]
  85     [ "deploy-config-" prepend temp-file ] bi
  86     [ utf8 set-file-contents ] keep ;
  87
  88 : deploy-command-line ( image vocab manifest-file profile -- flags )
  89     [
  90         "-pic=0" ,
  91         staging-image-name "-i=" prepend ,
  92         "-vocab-manifest-out=" prepend ,
  93         [ "-deploy-vocab=" prepend , ]
  94         [ make-deploy-config "-deploy-config=" prepend , ] bi
  95         "-output-image=" prepend ,
  96         "-resource-path=" "" resource-path append ,
  97         "-run=tools.deploy.shaker" ,
  98     ] { } make ;
  99
 100 : parse-vocab-manifest-file ( path -- vocab-manifest )
 101     utf8 file-lines [ "empty vocab manifest!" throw ] [
 102         unclip-slice "VOCABS:" =
 103         [ { "LIBRARIES:" } split1 vocab-manifest boa ]
 104         [ "invalid vocab manifest!" throw ] if
 105     ] if-empty ;
 106
 107 :: make-deploy-image ( vm image vocab config -- manifest )
 108     make-boot-image
 109
 110     config config>profile :> profile
 111     vocab "vocab-manifest-" prepend temp-file :> manifest-file
 112     image vocab manifest-file profile deploy-command-line :> flags
 113
 114     profile make-staging-image
 115     vm flags run-factor
 116     manifest-file parse-vocab-manifest-file ;
 117
 118 :: make-deploy-image-executable ( vm image vocab config -- manifest )
 119     vm image vocab config make-deploy-image
 120     image vm embed-image ;
 121
 122 SYMBOL: open-directory-after-deploy?
 123 t open-directory-after-deploy? set-global
 124
 125 : maybe-open-deploy-directory ( directory -- )
 126     absolute-path open-directory-after-deploy? get
 127     [ open-item ] [ drop ] if ;
 128
 129 HOOK: deploy* os ( vocab -- )
 130
 131 HOOK: deploy-path os ( vocab -- path )